home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Mouse / Tiny.pm < prev    next >
Encoding:
Text File  |  2010-07-26  |  108.7 KB  |  4,685 lines

  1. # This file was generated by tool/generate-mouse-tiny.pl from Mouse 0.64.
  2. #
  3. # ANY CHANGES MADE HERE WILL BE LOST!
  4. use strict;
  5. use warnings;
  6. # if regular Mouse is loaded, bail out
  7. unless ($INC{'Mouse.pm'}) {
  8. # tell Perl we already have all of the Mouse files loaded:
  9. $INC{'Mouse.pm'}                              = __FILE__;
  10. $INC{'Mouse/Role.pm'}                         = __FILE__;
  11. $INC{'Mouse/PurePerl.pm'}                     = __FILE__;
  12. $INC{'Mouse/Object.pm'}                       = __FILE__;
  13. $INC{'Mouse/Util.pm'}                         = __FILE__;
  14. $INC{'Mouse/Exporter.pm'}                     = __FILE__;
  15. $INC{'Mouse/Meta/Method.pm'}                  = __FILE__;
  16. $INC{'Mouse/Meta/Module.pm'}                  = __FILE__;
  17. $INC{'Mouse/Meta/Role.pm'}                    = __FILE__;
  18. $INC{'Mouse/Meta/Class.pm'}                   = __FILE__;
  19. $INC{'Mouse/Meta/Attribute.pm'}               = __FILE__;
  20. $INC{'Mouse/Meta/TypeConstraint.pm'}          = __FILE__;
  21. $INC{'Mouse/Meta/Role/Method.pm'}             = __FILE__;
  22. $INC{'Mouse/Meta/Role/Composite.pm'}          = __FILE__;
  23. $INC{'Mouse/Meta/Method/Accessor.pm'}         = __FILE__;
  24. $INC{'Mouse/Meta/Method/Destructor.pm'}       = __FILE__;
  25. $INC{'Mouse/Meta/Method/Constructor.pm'}      = __FILE__;
  26. $INC{'Mouse/Meta/Method/Delegation.pm'}       = __FILE__;
  27. $INC{'Mouse/Util/TypeConstraints.pm'}         = __FILE__;
  28. $INC{'Mouse/Util/MetaRole.pm'}                = __FILE__;
  29. eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY';
  30.  
  31. # and now their contents
  32.  
  33. BEGIN{ # lib/Mouse/PurePerl.pm
  34. package Mouse::PurePerl;
  35.  
  36. require Mouse::Util;
  37.  
  38. package Mouse::Util;
  39.  
  40. use strict;
  41. use warnings;
  42.  
  43. use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
  44.  
  45. use B ();
  46.  
  47.  
  48. # taken from Class/MOP.pm
  49. sub is_valid_class_name {
  50.     my $class = shift;
  51.  
  52.     return 0 if ref($class);
  53.     return 0 unless defined($class);
  54.  
  55.     return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;
  56.  
  57.     return 0;
  58. }
  59.  
  60. sub is_class_loaded {
  61.     my $class = shift;
  62.  
  63.     return 0 if ref($class) || !defined($class) || !length($class);
  64.  
  65.     # walk the symbol table tree to avoid autovififying
  66.     # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
  67.  
  68.     my $pack = \%::;
  69.     foreach my $part (split('::', $class)) {
  70.         $part .= '::';
  71.         return 0 if !exists $pack->{$part};
  72.  
  73.         my $entry = \$pack->{$part};
  74.         return 0 if ref($entry) ne 'GLOB';
  75.         $pack = *{$entry}{HASH};
  76.     }
  77.  
  78.     return 0 if !%{$pack};
  79.  
  80.     # check for $VERSION or @ISA
  81.     return 1 if exists $pack->{VERSION}
  82.              && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
  83.     return 1 if exists $pack->{ISA}
  84.              && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
  85.  
  86.     # check for any method
  87.     foreach my $name( keys %{$pack} ) {
  88.         my $entry = \$pack->{$name};
  89.         return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
  90.     }
  91.  
  92.     # fail
  93.     return 0;
  94. }
  95.  
  96.  
  97. # taken from Sub::Identify
  98. sub get_code_info {
  99.     my ($coderef) = @_;
  100.     ref($coderef) or return;
  101.  
  102.     my $cv = B::svref_2object($coderef);
  103.     $cv->isa('B::CV') or return;
  104.  
  105.     my $gv = $cv->GV;
  106.     $gv->isa('B::GV') or return;
  107.  
  108.     return ($gv->STASH->NAME, $gv->NAME);
  109. }
  110.  
  111. sub get_code_package{
  112.     my($coderef) = @_;
  113.  
  114.     my $cv = B::svref_2object($coderef);
  115.     $cv->isa('B::CV') or return '';
  116.  
  117.     my $gv = $cv->GV;
  118.     $gv->isa('B::GV') or return '';
  119.  
  120.     return $gv->STASH->NAME;
  121. }
  122.  
  123. sub get_code_ref{
  124.     my($package, $name) = @_;
  125.     no strict 'refs';
  126.     no warnings 'once';
  127.     use warnings FATAL => 'uninitialized';
  128.     return *{$package . '::' . $name}{CODE};
  129. }
  130.  
  131. sub generate_isa_predicate_for {
  132.     my($for_class, $name) = @_;
  133.  
  134.     my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
  135.  
  136.     if(defined $name){
  137.         Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
  138.         return;
  139.     }
  140.  
  141.     return $predicate;
  142. }
  143.  
  144. sub generate_can_predicate_for {
  145.     my($methods_ref, $name) = @_;
  146.  
  147.     my @methods = @{$methods_ref};
  148.  
  149.     my $predicate = sub{
  150.         my($instance) = @_;
  151.         if(Scalar::Util::blessed($instance)){
  152.             foreach my $method(@methods){
  153.                 if(!$instance->can($method)){
  154.                     return 0;
  155.                 }
  156.             }
  157.             return 1;
  158.         }
  159.         return 0;
  160.     };
  161.  
  162.     if(defined $name){
  163.         Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
  164.         return;
  165.     }
  166.  
  167.     return $predicate;
  168. }
  169.  
  170. package Mouse::Util::TypeConstraints;
  171.  
  172. use Scalar::Util qw(blessed looks_like_number openhandle);
  173.  
  174. sub Any        { 1 }
  175. sub Item       { 1 }
  176.  
  177. sub Bool       { $_[0] ? $_[0] eq '1' : 1 }
  178. sub Undef      { !defined($_[0]) }
  179. sub Defined    {  defined($_[0])  }
  180. sub Value      {  defined($_[0]) && !ref($_[0]) }
  181. sub Num        {  looks_like_number($_[0]) }
  182. sub Int        {
  183.     my($value) = @_;
  184.     looks_like_number($value) && $value =~ /\A [+-]? [0-9]+  \z/xms;
  185. }
  186. sub Str        {
  187.     my($value) = @_;
  188.     return defined($value) && ref(\$value) eq 'SCALAR';
  189. }
  190.  
  191. sub Ref        { ref($_[0]) }
  192. sub ScalarRef  {
  193.     my($value) = @_;
  194.     return ref($value) eq 'SCALAR'
  195. }
  196. sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
  197. sub HashRef    { ref($_[0]) eq 'HASH'   }
  198. sub CodeRef    { ref($_[0]) eq 'CODE'   }
  199. sub RegexpRef  { ref($_[0]) eq 'Regexp' }
  200. sub GlobRef    { ref($_[0]) eq 'GLOB'   }
  201.  
  202. sub FileHandle {
  203.     return openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
  204. }
  205.  
  206. sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
  207.  
  208. sub ClassName  { Mouse::Util::is_class_loaded($_[0]) }
  209. sub RoleName   { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
  210.  
  211. sub _parameterize_ArrayRef_for {
  212.     my($type_parameter) = @_;
  213.     my $check = $type_parameter->_compiled_type_constraint;
  214.  
  215.     return sub {
  216.         foreach my $value (@{$_}) {
  217.             return undef unless $check->($value);
  218.         }
  219.         return 1;
  220.     }
  221. }
  222.  
  223. sub _parameterize_HashRef_for {
  224.     my($type_parameter) = @_;
  225.     my $check = $type_parameter->_compiled_type_constraint;
  226.  
  227.     return sub {
  228.         foreach my $value(values %{$_}){
  229.             return undef unless $check->($value);
  230.         }
  231.         return 1;
  232.     };
  233. }
  234.  
  235. # 'Maybe' type accepts 'Any', so it requires parameters
  236. sub _parameterize_Maybe_for {
  237.     my($type_parameter) = @_;
  238.     my $check = $type_parameter->_compiled_type_constraint;
  239.  
  240.     return sub{
  241.         return !defined($_) || $check->($_);
  242.     };
  243. }
  244.  
  245. package Mouse::Meta::Module;
  246.  
  247. sub name          { $_[0]->{package} }
  248.  
  249. sub _method_map   { $_[0]->{methods} }
  250. sub _attribute_map{ $_[0]->{attributes} }
  251.  
  252. sub namespace{
  253.     my $name = $_[0]->{package};
  254.     no strict 'refs';
  255.     return \%{ $name . '::' };
  256. }
  257.  
  258. sub add_method {
  259.     my($self, $name, $code) = @_;
  260.  
  261.     if(!defined $name){
  262.         $self->throw_error('You must pass a defined name');
  263.     }
  264.     if(!defined $code){
  265.         $self->throw_error('You must pass a defined code');
  266.     }
  267.  
  268.     if(ref($code) ne 'CODE'){
  269.         $code = \&{$code}; # coerce
  270.     }
  271.  
  272.     $self->{methods}->{$name} = $code; # Moose stores meta object here.
  273.  
  274.     Mouse::Util::install_subroutines($self->name,
  275.         $name => $code,
  276.     );
  277.     return;
  278. }
  279.  
  280. package Mouse::Meta::Class;
  281.  
  282. use Mouse::Meta::Method::Constructor;
  283. use Mouse::Meta::Method::Destructor;
  284.  
  285. sub method_metaclass    { $_[0]->{method_metaclass}    || 'Mouse::Meta::Method'    }
  286. sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
  287.  
  288. sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
  289. sub destructor_class  { $_[0]->{destructor_class}  || 'Mouse::Meta::Method::Destructor'  }
  290.  
  291. sub is_anon_class{
  292.     return exists $_[0]->{anon_serial_id};
  293. }
  294.  
  295. sub roles { $_[0]->{roles} }
  296.  
  297. sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
  298.  
  299. sub get_all_attributes {
  300.     my($self) = @_;
  301.     my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
  302.     return values %attrs;
  303. }
  304.  
  305. sub new_object {
  306.     my $meta = shift;
  307.     my %args = (@_ == 1 ? %{$_[0]} : @_);
  308.  
  309.     my $object = bless {}, $meta->name;
  310.  
  311.     $meta->_initialize_object($object, \%args);
  312.     # BUILDALL
  313.     if( $object->can('BUILD') ) {
  314.         for my $class (reverse $meta->linearized_isa) {
  315.             my $build = Mouse::Util::get_code_ref($class, 'BUILD')
  316.                 || next;
  317.  
  318.             $object->$build(\%args);
  319.         }
  320.     }
  321.     return $object;
  322. }
  323.  
  324. sub clone_object {
  325.     my $class  = shift;
  326.     my $object = shift;
  327.     my $args   = $object->Mouse::Object::BUILDARGS(@_);
  328.  
  329.     (blessed($object) && $object->isa($class->name))
  330.         || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
  331.  
  332.     my $cloned = bless { %$object }, ref $object;
  333.     $class->_initialize_object($cloned, $args, 1);
  334.  
  335.     return $cloned;
  336. }
  337.  
  338. sub _initialize_object{
  339.     my($self, $object, $args, $is_cloning) = @_;
  340.  
  341.     my @triggers_queue;
  342.  
  343.     my $used = 0;
  344.  
  345.     foreach my $attribute ($self->get_all_attributes) {
  346.         my $init_arg = $attribute->init_arg;
  347.         my $slot     = $attribute->name;
  348.  
  349.         if (defined($init_arg) && exists($args->{$init_arg})) {
  350.             $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);
  351.  
  352.             weaken($object->{$slot})
  353.                 if ref($object->{$slot}) && $attribute->is_weak_ref;
  354.  
  355.             if ($attribute->has_trigger) {
  356.                 push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
  357.             }
  358.             $used++;
  359.         }
  360.         else { # no init arg
  361.             if ($attribute->has_default || $attribute->has_builder) {
  362.                 if (!$attribute->is_lazy && !exists $object->{$slot}) {
  363.                     my $default = $attribute->default;
  364.                     my $builder = $attribute->builder;
  365.                     my $value =   $builder                ? $object->$builder()
  366.                                 : ref($default) eq 'CODE' ? $object->$default()
  367.                                 :                           $default;
  368.  
  369.                     $object->{$slot} = $attribute->_coerce_and_verify($value, $object);
  370.  
  371.                     weaken($object->{$slot})
  372.                         if ref($object->{$slot}) && $attribute->is_weak_ref;
  373.                 }
  374.             }
  375.             elsif(!$is_cloning && $attribute->is_required) {
  376.                 $self->throw_error("Attribute (".$attribute->name.") is required");
  377.             }
  378.         }
  379.     }
  380.  
  381.     if($used < keys %{$args} && $self->strict_constructor) {
  382.         $self->_report_unknown_args([ $self->get_all_attributes ], $args);
  383.     }
  384.  
  385.     if(@triggers_queue){
  386.         foreach my $trigger_and_value(@triggers_queue){
  387.             my($trigger, $value) = @{$trigger_and_value};
  388.             $trigger->($object, $value);
  389.         }
  390.     }
  391.  
  392.     if($self->is_anon_class){
  393.         $object->{__METACLASS__} = $self;
  394.     }
  395.  
  396.     return;
  397. }
  398.  
  399. sub is_immutable {  $_[0]->{is_immutable} }
  400.  
  401. sub strict_constructor{
  402.     my $self = shift;
  403.     if(@_) {
  404.         $self->{strict_constructor} = shift;
  405.     }
  406.  
  407.     foreach my $class($self->linearized_isa) {
  408.         my $meta = Mouse::Util::get_metaclass_by_name($class)
  409.             or next;
  410.  
  411.         if(exists $meta->{strict_constructor}) {
  412.             return $meta->{strict_constructor};
  413.         }
  414.     }
  415.  
  416.     return 0; # false
  417. }
  418.  
  419. sub _report_unknown_args {
  420.     my($metaclass, $attrs, $args) = @_;
  421.  
  422.     my @unknowns;
  423.     my %init_args;
  424.     foreach my $attr(@{$attrs}){
  425.         my $init_arg = $attr->init_arg;
  426.         if(defined $init_arg){
  427.             $init_args{$init_arg}++;
  428.         }
  429.     }
  430.  
  431.     while(my $key = each %{$args}){
  432.         if(!exists $init_args{$key}){
  433.             push @unknowns, $key;
  434.         }
  435.     }
  436.  
  437.     $metaclass->throw_error( sprintf
  438.         "Unknown attribute passed to the constructor of %s: %s",
  439.         $metaclass->name, Mouse::Util::english_list(@unknowns),
  440.     );
  441. }
  442.  
  443. package Mouse::Meta::Role;
  444.  
  445. sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
  446.  
  447. sub is_anon_role{
  448.     return exists $_[0]->{anon_serial_id};
  449. }
  450.  
  451. sub get_roles { $_[0]->{roles} }
  452.  
  453. sub add_before_method_modifier {
  454.     my ($self, $method_name, $method) = @_;
  455.  
  456.     push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
  457.     return;
  458. }
  459. sub add_around_method_modifier {
  460.     my ($self, $method_name, $method) = @_;
  461.  
  462.     push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
  463.     return;
  464. }
  465. sub add_after_method_modifier {
  466.     my ($self, $method_name, $method) = @_;
  467.  
  468.     push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
  469.     return;
  470. }
  471.  
  472. sub get_before_method_modifiers {
  473.     my ($self, $method_name) = @_;
  474.     return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
  475. }
  476. sub get_around_method_modifiers {
  477.     my ($self, $method_name) = @_;
  478.     return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
  479. }
  480. sub get_after_method_modifiers {
  481.     my ($self, $method_name) = @_;
  482.     return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
  483. }
  484.  
  485. package Mouse::Meta::Attribute;
  486.  
  487. require Mouse::Meta::Method::Accessor;
  488.  
  489. sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
  490.  
  491. # readers
  492.  
  493. sub name                 { $_[0]->{name}                   }
  494. sub associated_class     { $_[0]->{associated_class}       }
  495.  
  496. sub accessor             { $_[0]->{accessor}               }
  497. sub reader               { $_[0]->{reader}                 }
  498. sub writer               { $_[0]->{writer}                 }
  499. sub predicate            { $_[0]->{predicate}              }
  500. sub clearer              { $_[0]->{clearer}                }
  501. sub handles              { $_[0]->{handles}                }
  502.  
  503. sub _is_metadata         { $_[0]->{is}                     }
  504. sub is_required          { $_[0]->{required}               }
  505. sub default              { $_[0]->{default}                }
  506. sub is_lazy              { $_[0]->{lazy}                   }
  507. sub is_lazy_build        { $_[0]->{lazy_build}             }
  508. sub is_weak_ref          { $_[0]->{weak_ref}               }
  509. sub init_arg             { $_[0]->{init_arg}               }
  510. sub type_constraint      { $_[0]->{type_constraint}        }
  511.  
  512. sub trigger              { $_[0]->{trigger}                }
  513. sub builder              { $_[0]->{builder}                }
  514. sub should_auto_deref    { $_[0]->{auto_deref}             }
  515. sub should_coerce        { $_[0]->{coerce}                 }
  516.  
  517. sub documentation        { $_[0]->{documentation}          }
  518. sub insertion_order      { $_[0]->{insertion_order}        }
  519.  
  520. # predicates
  521.  
  522. sub has_accessor         { exists $_[0]->{accessor}        }
  523. sub has_reader           { exists $_[0]->{reader}          }
  524. sub has_writer           { exists $_[0]->{writer}          }
  525. sub has_predicate        { exists $_[0]->{predicate}       }
  526. sub has_clearer          { exists $_[0]->{clearer}         }
  527. sub has_handles          { exists $_[0]->{handles}         }
  528.  
  529. sub has_default          { exists $_[0]->{default}         }
  530. sub has_type_constraint  { exists $_[0]->{type_constraint} }
  531. sub has_trigger          { exists $_[0]->{trigger}         }
  532. sub has_builder          { exists $_[0]->{builder}         }
  533.  
  534. sub has_documentation    { exists $_[0]->{documentation}   }
  535.  
  536. sub _process_options{
  537.     my($class, $name, $args) = @_;
  538.  
  539.     # taken from Class::MOP::Attribute::new
  540.  
  541.     defined($name)
  542.         or $class->throw_error('You must provide a name for the attribute');
  543.  
  544.     if(!exists $args->{init_arg}){
  545.         $args->{init_arg} = $name;
  546.     }
  547.  
  548.     # 'required' requires eigher 'init_arg', 'builder', or 'default'
  549.     my $can_be_required = defined( $args->{init_arg} );
  550.  
  551.     if(exists $args->{builder}){
  552.         # XXX:
  553.         # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
  554.         # This feature will be changed in a future. (gfx)
  555.         $class->throw_error('builder must be a defined scalar value which is a method name')
  556.             #if ref $args->{builder} || !defined $args->{builder};
  557.             if !defined $args->{builder};
  558.  
  559.         $can_be_required++;
  560.     }
  561.     elsif(exists $args->{default}){
  562.         if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
  563.             $class->throw_error("References are not allowed as default values, you must "
  564.                               . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
  565.         }
  566.         $can_be_required++;
  567.     }
  568.  
  569.     if( $args->{required} && !$can_be_required ) {
  570.         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
  571.     }
  572.  
  573.     # taken from Mouse::Meta::Attribute->new and ->_process_args
  574.  
  575.     if(exists $args->{is}){
  576.         my $is = $args->{is};
  577.  
  578.         if($is eq 'ro'){
  579.             $args->{reader} ||= $name;
  580.         }
  581.         elsif($is eq 'rw'){
  582.             if(exists $args->{writer}){
  583.                 $args->{reader} ||= $name;
  584.              }
  585.              else{
  586.                 $args->{accessor} ||= $name;
  587.              }
  588.         }
  589.         elsif($is eq 'bare'){
  590.             # do nothing, but don't complain (later) about missing methods
  591.         }
  592.         else{
  593.             $is = 'undef' if !defined $is;
  594.             $class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
  595.         }
  596.     }
  597.  
  598.     my $tc;
  599.     if(exists $args->{isa}){
  600.         $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
  601.     }
  602.  
  603.     if(exists $args->{does}){
  604.         if(defined $tc){ # both isa and does supplied
  605.             my $does_ok = do{
  606.                 local $@;
  607.                 eval{ "$tc"->does($args) };
  608.             };
  609.             if(!$does_ok){
  610.                 $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
  611.             }
  612.         }
  613.         else {
  614.             $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
  615.         }
  616.     }
  617.  
  618.     if($args->{coerce}){
  619.         defined($tc)
  620.             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");
  621.  
  622.         $args->{weak_ref}
  623.             && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
  624.     }
  625.  
  626.     if ($args->{lazy_build}) {
  627.         exists($args->{default})
  628.             && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");
  629.  
  630.         $args->{lazy}      = 1;
  631.         $args->{builder} ||= "_build_${name}";
  632.         if ($name =~ /^_/) {
  633.             $args->{clearer}   ||= "_clear${name}";
  634.             $args->{predicate} ||= "_has${name}";
  635.         }
  636.         else {
  637.             $args->{clearer}   ||= "clear_${name}";
  638.             $args->{predicate} ||= "has_${name}";
  639.         }
  640.     }
  641.  
  642.     if ($args->{auto_deref}) {
  643.         defined($tc)
  644.             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");
  645.  
  646.         ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
  647.             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
  648.     }
  649.  
  650.     if (exists $args->{trigger}) {
  651.         ('CODE' eq ref $args->{trigger})
  652.             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
  653.     }
  654.  
  655.     if ($args->{lazy}) {
  656.         (exists $args->{default} || defined $args->{builder})
  657.             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it");
  658.     }
  659.  
  660.     return;
  661. }
  662.  
  663.  
  664. package Mouse::Meta::TypeConstraint;
  665.  
  666. sub name    { $_[0]->{name}    }
  667. sub parent  { $_[0]->{parent}  }
  668. sub message { $_[0]->{message} }
  669.  
  670. sub type_parameter           { $_[0]->{type_parameter} }
  671. sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
  672. sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }
  673.  
  674. sub __is_parameterized { exists $_[0]->{type_parameter} }
  675. sub has_coercion {       exists $_[0]->{_compiled_type_coercion} }
  676.  
  677.  
  678. sub compile_type_constraint{
  679.     my($self) = @_;
  680.  
  681.     # add parents first
  682.     my @checks;
  683.     for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
  684.          if($parent->{hand_optimized_type_constraint}){
  685.             unshift @checks, $parent->{hand_optimized_type_constraint};
  686.             last; # a hand optimized constraint must include all the parents
  687.         }
  688.         elsif($parent->{constraint}){
  689.             unshift @checks, $parent->{constraint};
  690.         }
  691.     }
  692.  
  693.     # then add child
  694.     if($self->{constraint}){
  695.         push @checks, $self->{constraint};
  696.     }
  697.  
  698.     if($self->{type_constraints}){ # Union
  699.         my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
  700.         push @checks, sub{
  701.             foreach my $c(@types){
  702.                 return 1 if $c->($_[0]);
  703.             }
  704.             return 0;
  705.         };
  706.     }
  707.  
  708.     if(@checks == 0){
  709.         $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
  710.     }
  711.     else{
  712.         $self->{compiled_type_constraint} =  sub{
  713.             my(@args) = @_;
  714.             local $_ = $args[0];
  715.             foreach my $c(@checks){
  716.                 return undef if !$c->(@args);
  717.             }
  718.             return 1;
  719.         };
  720.     }
  721.     return;
  722. }
  723.  
  724. sub check {
  725.     my $self = shift;
  726.     return $self->_compiled_type_constraint->(@_);
  727. }
  728.  
  729.  
  730. package Mouse::Object;
  731.  
  732. sub BUILDARGS {
  733.     my $class = shift;
  734.  
  735.     if (scalar @_ == 1) {
  736.         (ref($_[0]) eq 'HASH')
  737.             || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
  738.  
  739.         return {%{$_[0]}};
  740.     }
  741.     else {
  742.         return {@_};
  743.     }
  744. }
  745.  
  746. sub new {
  747.     my $class = shift;
  748.  
  749.     $class->meta->throw_error('Cannot call new() on an instance') if ref $class;
  750.  
  751.     my $args = $class->BUILDARGS(@_);
  752.  
  753.     my $meta = Mouse::Meta::Class->initialize($class);
  754.     return $meta->new_object($args);
  755. }
  756.  
  757. sub DESTROY {
  758.     my $self = shift;
  759.  
  760.     return unless $self->can('DEMOLISH'); # short circuit
  761.  
  762.     local $?;
  763.  
  764.     my $e = do{
  765.         local $@;
  766.         eval{
  767.             # DEMOLISHALL
  768.  
  769.             # We cannot count on being able to retrieve a previously made
  770.             # metaclass, _or_ being able to make a new one during global
  771.             # destruction. However, we should still be able to use mro at
  772.             # that time (at least tests suggest so ;)
  773.  
  774.             foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
  775.                 my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
  776.                     || next;
  777.  
  778.                 $self->$demolish($Mouse::Util::in_global_destruction);
  779.             }
  780.         };
  781.         $@;
  782.     };
  783.  
  784.     no warnings 'misc';
  785.     die $e if $e; # rethrow
  786. }
  787.  
  788. sub BUILDALL {
  789.     my $self = shift;
  790.  
  791.     # short circuit
  792.     return unless $self->can('BUILD');
  793.  
  794.     for my $class (reverse $self->meta->linearized_isa) {
  795.         my $build = Mouse::Util::get_code_ref($class, 'BUILD')
  796.             || next;
  797.  
  798.         $self->$build(@_);
  799.     }
  800.     return;
  801. }
  802.  
  803. sub DEMOLISHALL;
  804. *DEMOLISHALL = \&DESTROY;
  805.  
  806. }
  807. BEGIN{ # lib/Mouse/Exporter.pm
  808. package Mouse::Exporter;
  809. use strict;
  810. use warnings;
  811.  
  812. use Carp qw(confess);
  813.  
  814. my %SPEC;
  815.  
  816. my $strict_bits;
  817. BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); }
  818.  
  819. my $warnings_extra_bits;
  820. BEGIN{ $warnings_extra_bits = warnings::bits(FATAL => 'recursion') }
  821.  
  822. # it must be "require", because Mouse::Util depends on Mouse::Exporter,
  823. # which depends on Mouse::Util::import()
  824. require Mouse::Util;
  825.  
  826. sub import{
  827.     # strict->import;
  828.     $^H              |= $strict_bits;
  829.     # warnings->import('all', FATAL => 'recursion');
  830.     ${^WARNING_BITS} |= $warnings::Bits{all};
  831.     ${^WARNING_BITS} |= $warnings_extra_bits;
  832.     return;
  833. }
  834.  
  835.  
  836. sub setup_import_methods{
  837.     my($class, %args) = @_;
  838.  
  839.     my $exporting_package = $args{exporting_package} ||= caller();
  840.  
  841.     my($import, $unimport) = $class->build_import_methods(%args);
  842.  
  843.     Mouse::Util::install_subroutines($exporting_package,
  844.         import   => $import,
  845.         unimport => $unimport,
  846.  
  847.         export_to_level => sub {
  848.             my($package, $level, undef, @args) = @_; # the third argument is redundant
  849.             $package->import({ into_level => $level + 1 }, @args);
  850.         },
  851.         export => sub {
  852.             my($package, $into, @args) = @_;
  853.             $package->import({ into => $into }, @args);
  854.         },
  855.     );
  856.     return;
  857. }
  858.  
  859. sub build_import_methods{
  860.     my($self, %args) = @_;
  861.  
  862.     my $exporting_package = $args{exporting_package} ||= caller();
  863.  
  864.     $SPEC{$exporting_package} = \%args;
  865.  
  866.     # canonicalize args
  867.     my @export_from;
  868.     if($args{also}){
  869.         my %seen;
  870.         my @stack = ($exporting_package);
  871.  
  872.         while(my $current = shift @stack){
  873.             push @export_from, $current;
  874.  
  875.             my $also = $SPEC{$current}{also} or next;
  876.             push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also;
  877.         }
  878.     }
  879.     else{
  880.         @export_from = ($exporting_package);
  881.     }
  882.  
  883.     my %exports;
  884.     my @removables;
  885.     my @all;
  886.  
  887.     my @init_meta_methods;
  888.  
  889.     foreach my $package(@export_from){
  890.         my $spec = $SPEC{$package} or next;
  891.  
  892.         if(my $as_is = $spec->{as_is}){
  893.             foreach my $thingy (@{$as_is}){
  894.                 my($code_package, $code_name, $code);
  895.  
  896.                 if(ref($thingy)){
  897.                     $code = $thingy;
  898.                     ($code_package, $code_name) = Mouse::Util::get_code_info($code);
  899.                 }
  900.                 else{
  901.                     $code_package = $package;
  902.                     $code_name    = $thingy;
  903.                     no strict 'refs';
  904.                     $code         = \&{ $code_package . '::' . $code_name };
  905.                }
  906.  
  907.                 push @all, $code_name;
  908.                 $exports{$code_name} = $code;
  909.                 if($code_package eq $package){
  910.                     push @removables, $code_name;
  911.                 }
  912.             }
  913.         }
  914.  
  915.         if(my $init_meta = $package->can('init_meta')){
  916.             if(!grep{ $_ == $init_meta } @init_meta_methods){
  917.                 push @init_meta_methods, $init_meta;
  918.             }
  919.         }
  920.     }
  921.     $args{EXPORTS}    = \%exports;
  922.     $args{REMOVABLES} = \@removables;
  923.  
  924.     $args{groups}{all}     ||= \@all;
  925.  
  926.     if(my $default_list = $args{groups}{default}){
  927.         my %default;
  928.         foreach my $keyword(@{$default_list}){
  929.             $default{$keyword} = $exports{$keyword}
  930.                 || confess(qq{The $exporting_package package does not export "$keyword"});
  931.         }
  932.         $args{DEFAULT} = \%default;
  933.     }
  934.     else{
  935.         $args{groups}{default} ||= \@all;
  936.         $args{DEFAULT}           = $args{EXPORTS};
  937.     }
  938.  
  939.     if(@init_meta_methods){
  940.         $args{INIT_META} = \@init_meta_methods;
  941.     }
  942.  
  943.     return (\&do_import, \&do_unimport);
  944. }
  945.  
  946.  
  947. # the entity of general import()
  948. sub do_import {
  949.     my($package, @args) = @_;
  950.  
  951.     my $spec = $SPEC{$package}
  952.         || confess("The package $package package does not use Mouse::Exporter");
  953.  
  954.     my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);
  955.  
  956.     my @exports;
  957.     my @traits;
  958.  
  959.     while(@args){
  960.         my $arg = shift @args;
  961.         if($arg =~ s/^-//){
  962.             if($arg eq 'traits'){
  963.                 push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args);
  964.             }
  965.             else {
  966.                 Mouse::Util::not_supported("-$arg");
  967.             }
  968.         }
  969.         elsif($arg =~ s/^://){
  970.             my $group = $spec->{groups}{$arg}
  971.                 || confess(qq{The $package package does not export the group "$arg"});
  972.             push @exports, @{$group};
  973.         }
  974.         else{
  975.             push @exports, $arg;
  976.         }
  977.     }
  978.  
  979.     $^H              |= $strict_bits;                                 # strict->import;
  980.     # warnings->import('all', FATAL => 'recursion');
  981.     ${^WARNING_BITS} |= $warnings::Bits{all};
  982.     ${^WARNING_BITS} |= $warnings_extra_bits;
  983.  
  984.     if($spec->{INIT_META}){
  985.         my $meta;
  986.         foreach my $init_meta(@{$spec->{INIT_META}}){
  987.             $meta = $package->$init_meta(for_class => $into);
  988.         }
  989.  
  990.         if(@traits){
  991.             my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class"
  992.             @traits =
  993.                 map{
  994.                     ref($_) ? $_
  995.                             : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1)
  996.                 } @traits;
  997.  
  998.             require Mouse::Util::MetaRole;
  999.             Mouse::Util::MetaRole::apply_metaroles(
  1000.                 for       => $into,
  1001.                 Mouse::Util::is_a_metarole($into->meta)
  1002.                     ? (role_metaroles  => { role  => \@traits })
  1003.                     : (class_metaroles => { class => \@traits }),
  1004.             );
  1005.         }
  1006.     }
  1007.     elsif(@traits){
  1008.         Carp::confess("Cannot provide traits when $package does not have an init_meta() method");
  1009.     }
  1010.  
  1011.     if(@exports){
  1012.         my @export_table;
  1013.         foreach my $keyword(@exports){
  1014.             push @export_table,
  1015.                 $keyword => ($spec->{EXPORTS}{$keyword}
  1016.                     || confess(qq{The $package package does not export "$keyword"})
  1017.                 );
  1018.         }
  1019.         Mouse::Util::install_subroutines($into, @export_table);
  1020.     }
  1021.     else{
  1022.         Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}});
  1023.     }
  1024.     return;
  1025. }
  1026.  
  1027. # the entity of general unimport()
  1028. sub do_unimport {
  1029.     my($package, $arg) = @_;
  1030.  
  1031.     my $spec = $SPEC{$package}
  1032.         || confess("The package $package does not use Mouse::Exporter");
  1033.  
  1034.     my $from = _get_caller_package($arg);
  1035.  
  1036.     my $stash = do{
  1037.         no strict 'refs';
  1038.         \%{$from . '::'}
  1039.     };
  1040.  
  1041.     for my $keyword (@{ $spec->{REMOVABLES} }) {
  1042.         next if !exists $stash->{$keyword};
  1043.         my $gv = \$stash->{$keyword};
  1044.         if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
  1045.             delete $stash->{$keyword};
  1046.         }
  1047.     }
  1048.     return;
  1049. }
  1050.  
  1051. sub _get_caller_package {
  1052.     my($arg) = @_;
  1053.  
  1054.     # We need one extra level because it's called by import so there's a layer
  1055.     # of indirection
  1056.     if(ref $arg){
  1057.         return defined($arg->{into})       ? $arg->{into}
  1058.              : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level})
  1059.              :                               scalar caller(1);
  1060.     }
  1061.     else{
  1062.         return scalar caller(1);
  1063.     }
  1064. }
  1065.  
  1066. #sub _spec{ %SPEC }
  1067.  
  1068. }
  1069. BEGIN{ # lib/Mouse/Util.pm
  1070. package Mouse::Util;
  1071. use Mouse::Exporter; # enables strict and warnings
  1072.  
  1073. # must be here because it will be refered by other modules loaded
  1074. sub get_linear_isa($;$); ## no critic
  1075.  
  1076. # must be here because it will called in Mouse::Exporter
  1077. sub install_subroutines {
  1078.     my $into = shift;
  1079.  
  1080.     while(my($name, $code) = splice @_, 0, 2){
  1081.         no strict 'refs';
  1082.         no warnings 'once', 'redefine';
  1083.         use warnings FATAL => 'uninitialized';
  1084.         *{$into . '::' . $name} = \&{$code};
  1085.     }
  1086.     return;
  1087. }
  1088.  
  1089. BEGIN{
  1090.     # This is used in Mouse::PurePerl
  1091.     Mouse::Exporter->setup_import_methods(
  1092.         as_is => [qw(
  1093.             find_meta
  1094.             does_role
  1095.             resolve_metaclass_alias
  1096.             apply_all_roles
  1097.             english_list
  1098.  
  1099.             load_class
  1100.             is_class_loaded
  1101.  
  1102.             get_linear_isa
  1103.             get_code_info
  1104.  
  1105.             get_code_package
  1106.             get_code_ref
  1107.  
  1108.             not_supported
  1109.  
  1110.             does meta dump
  1111.         )],
  1112.         groups => {
  1113.             default => [], # export no functions by default
  1114.  
  1115.             # The ':meta' group is 'use metaclass' for Mouse
  1116.             meta    => [qw(does meta dump)],
  1117.         },
  1118.     );
  1119.  
  1120.  
  1121.     # Because Mouse::Util is loaded first in all the Mouse sub-modules,
  1122.     # XS loader is placed here, not in Mouse.pm.
  1123.  
  1124.     our $VERSION = '0.64';
  1125.  
  1126.     my $xs = !(exists $INC{'Mouse/PurePerl.pm'} || $ENV{MOUSE_PUREPERL});
  1127.  
  1128.     if($xs){
  1129.         # XXX: XSLoader tries to get the object path from caller's file name
  1130.         #      $hack_mouse_file fools its mechanism
  1131.  
  1132.         (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
  1133.         $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
  1134.             local $^W = 0; # work around 'redefine' warning to &install_subroutines
  1135.             require XSLoader;
  1136.             XSLoader::load('Mouse', $VERSION);
  1137.             Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');
  1138.             Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS'  }, ':meta');
  1139.             Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS'    }, ':meta');
  1140.             return 1;
  1141.         } || 0;
  1142.         #warn $@ if $@;
  1143.     }
  1144.  
  1145.     if(!$xs){
  1146.         require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
  1147.     }
  1148.  
  1149.     *MOUSE_XS = sub(){ $xs };
  1150. }
  1151.  
  1152. use Carp         ();
  1153. use Scalar::Util ();
  1154.  
  1155. # aliases as public APIs
  1156. # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
  1157. require Mouse::Meta::Module; # for the entities of metaclass cache utilities
  1158.  
  1159. # aliases
  1160. {
  1161.     *class_of                    = \&Mouse::Meta::Module::_class_of;
  1162.     *get_metaclass_by_name       = \&Mouse::Meta::Module::_get_metaclass_by_name;
  1163.     *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances;
  1164.     *get_all_metaclass_names     = \&Mouse::Meta::Module::_get_all_metaclass_names;
  1165.  
  1166.     *Mouse::load_class           = \&load_class;
  1167.     *Mouse::is_class_loaded      = \&is_class_loaded;
  1168.  
  1169.     # is-a predicates
  1170.     #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
  1171.     #generate_isa_predicate_for('Mouse::Meta::Class'          => 'is_a_metaclass');
  1172.     #generate_isa_predicate_for('Mouse::Meta::Role'           => 'is_a_metarole');
  1173.  
  1174.     # duck type predicates
  1175.     generate_can_predicate_for(['_compiled_type_constraint']  => 'is_a_type_constraint');
  1176.     generate_can_predicate_for(['create_anon_class']          => 'is_a_metaclass');
  1177.     generate_can_predicate_for(['create_anon_role']           => 'is_a_metarole');
  1178. }
  1179.  
  1180. our $in_global_destruction = 0;
  1181. END{ $in_global_destruction = 1 }
  1182.  
  1183. # Moose::Util compatible utilities
  1184.  
  1185. sub find_meta{
  1186.     return class_of( $_[0] );
  1187. }
  1188.  
  1189. sub does_role{
  1190.     my ($class_or_obj, $role_name) = @_;
  1191.  
  1192.     my $meta = class_of($class_or_obj);
  1193.  
  1194.     (defined $role_name)
  1195.         || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
  1196.  
  1197.     return defined($meta) && $meta->does_role($role_name);
  1198. }
  1199.  
  1200. BEGIN {
  1201.     my $get_linear_isa;
  1202.     if ($] >= 5.009_005) {
  1203.         require mro;
  1204.         $get_linear_isa = \&mro::get_linear_isa;
  1205.     } else {
  1206.         # this code is based on MRO::Compat::__get_linear_isa
  1207.         my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  1208.         $_get_linear_isa_dfs = sub {
  1209.             my($classname) = @_;
  1210.  
  1211.             my @lin = ($classname);
  1212.             my %stored;
  1213.  
  1214.             no strict 'refs';
  1215.             foreach my $parent (@{"$classname\::ISA"}) {
  1216.                 foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
  1217.                     next if exists $stored{$p};
  1218.                     push(@lin, $p);
  1219.                     $stored{$p} = 1;
  1220.                 }
  1221.             }
  1222.             return \@lin;
  1223.         };
  1224.  
  1225.         {
  1226.             package # hide from PAUSE
  1227.                 Class::C3;
  1228.             our %MRO; # work around 'once' warnings
  1229.         }
  1230.  
  1231.         # MRO::Compat::__get_linear_isa has no prototype, so
  1232.         # we define a prototyped version for compatibility with core's
  1233.         # See also MRO::Compat::__get_linear_isa.
  1234.         $get_linear_isa = sub ($;$){
  1235.             my($classname, $type) = @_;
  1236.  
  1237.             if(!defined $type){
  1238.                 $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
  1239.             }
  1240.             if($type eq 'c3'){
  1241.                 require Class::C3;
  1242.                 return [Class::C3::calculateMRO($classname)];
  1243.             }
  1244.             else{
  1245.                 return $_get_linear_isa_dfs->($classname);
  1246.             }
  1247.         };
  1248.     }
  1249.  
  1250.     *get_linear_isa = $get_linear_isa;
  1251. }
  1252.  
  1253.  
  1254. # taken from Mouse::Util (0.90)
  1255. {
  1256.     my %cache;
  1257.  
  1258.     sub resolve_metaclass_alias {
  1259.         my ( $type, $metaclass_name, %options ) = @_;
  1260.  
  1261.         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
  1262.  
  1263.         return $cache{$cache_key}{$metaclass_name} ||= do{
  1264.  
  1265.             my $possible_full_name = join '::',
  1266.                 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
  1267.             ;
  1268.  
  1269.             my $loaded_class = load_first_existing_class(
  1270.                 $possible_full_name,
  1271.                 $metaclass_name
  1272.             );
  1273.  
  1274.             $loaded_class->can('register_implementation')
  1275.                 ? $loaded_class->register_implementation
  1276.                 : $loaded_class;
  1277.         };
  1278.     }
  1279. }
  1280.  
  1281. # Utilities from Class::MOP
  1282.  
  1283. sub get_code_info;
  1284. sub get_code_package;
  1285.  
  1286. sub is_valid_class_name;
  1287.  
  1288. # taken from Class/MOP.pm
  1289. sub load_first_existing_class {
  1290.     my @classes = @_
  1291.       or return;
  1292.  
  1293.     my %exceptions;
  1294.     for my $class (@classes) {
  1295.         my $e = _try_load_one_class($class);
  1296.  
  1297.         if ($e) {
  1298.             $exceptions{$class} = $e;
  1299.         }
  1300.         else {
  1301.             return $class;
  1302.         }
  1303.     }
  1304.  
  1305.     # not found
  1306.     Carp::confess join(
  1307.         "\n",
  1308.         map {
  1309.             sprintf( "Could not load class (%s) because : %s",
  1310.                 $_, $exceptions{$_} )
  1311.           } @classes
  1312.     );
  1313. }
  1314.  
  1315. # taken from Class/MOP.pm
  1316. sub _try_load_one_class {
  1317.     my $class = shift;
  1318.  
  1319.     unless ( is_valid_class_name($class) ) {
  1320.         my $display = defined($class) ? $class : 'undef';
  1321.         Carp::confess "Invalid class name ($display)";
  1322.     }
  1323.  
  1324.     return '' if is_class_loaded($class);
  1325.  
  1326.     $class  =~ s{::}{/}g;
  1327.     $class .= '.pm';
  1328.  
  1329.     return do {
  1330.         local $@;
  1331.         eval { require $class };
  1332.         $@;
  1333.     };
  1334. }
  1335.  
  1336.  
  1337. sub load_class {
  1338.     my $class = shift;
  1339.     my $e = _try_load_one_class($class);
  1340.     Carp::confess "Could not load class ($class) because : $e" if $e;
  1341.  
  1342.     return $class;
  1343. }
  1344.  
  1345. sub is_class_loaded;
  1346.  
  1347. sub apply_all_roles {
  1348.     my $consumer = Scalar::Util::blessed($_[0])
  1349.         ?                                shift   # instance
  1350.         : Mouse::Meta::Class->initialize(shift); # class or role name
  1351.  
  1352.     my @roles;
  1353.  
  1354.     # Basis of Data::OptList
  1355.     my $max = scalar(@_);
  1356.     for (my $i = 0; $i < $max ; $i++) {
  1357.         if ($i + 1 < $max && ref($_[$i + 1])) {
  1358.             push @roles, [ $_[$i] => $_[++$i] ];
  1359.         } else {
  1360.             push @roles, [ $_[$i] => undef ];
  1361.         }
  1362.         my $role_name = $roles[-1][0];
  1363.         load_class($role_name);
  1364.  
  1365.         is_a_metarole( get_metaclass_by_name($role_name) )
  1366.             || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
  1367.     }
  1368.  
  1369.     if ( scalar @roles == 1 ) {
  1370.         my ( $role_name, $params ) = @{ $roles[0] };
  1371.         get_metaclass_by_name($role_name)->apply( $consumer, defined $params ? $params : () );
  1372.     }
  1373.     else {
  1374.         Mouse::Meta::Role->combine(@roles)->apply($consumer);
  1375.     }
  1376.     return;
  1377. }
  1378.  
  1379. # taken from Moose::Util 0.90
  1380. sub english_list {
  1381.     return $_[0] if @_ == 1;
  1382.  
  1383.     my @items = sort @_;
  1384.  
  1385.     return "$items[0] and $items[1]" if @items == 2;
  1386.  
  1387.     my $tail = pop @items;
  1388.  
  1389.     return join q{, }, @items, "and $tail";
  1390. }
  1391.  
  1392. sub quoted_english_list {
  1393.     return english_list(map { qq{'$_'} } @_);
  1394. }
  1395.  
  1396. # common utilities
  1397.  
  1398. sub not_supported{
  1399.     my($feature) = @_;
  1400.  
  1401.     $feature ||= ( caller(1) )[3]; # subroutine name
  1402.  
  1403.     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
  1404.     Carp::confess("Mouse does not currently support $feature");
  1405. }
  1406.  
  1407. # general meta() method
  1408. sub meta :method{
  1409.     return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
  1410. }
  1411.  
  1412. # general dump() method
  1413. sub dump :method {
  1414.     my($self, $maxdepth) = @_;
  1415.  
  1416.     require 'Data/Dumper.pm'; # we don't want to create its namespace
  1417.     my $dd = Data::Dumper->new([$self]);
  1418.     $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
  1419.     $dd->Indent(1);
  1420.     return $dd->Dump();
  1421. }
  1422.  
  1423. # general does() method
  1424. sub does :method {
  1425.     goto &does_role;
  1426. }
  1427.  
  1428. }
  1429. BEGIN{ # lib/Mouse/Meta/TypeConstraint.pm
  1430. package Mouse::Meta::TypeConstraint;
  1431. use Mouse::Util qw(:meta); # enables strict and warnings
  1432. use Scalar::Util ();
  1433.  
  1434. use overload
  1435.     'bool'   => sub (){ 1 },           # always true
  1436.     '""'     => sub { $_[0]->name },   # stringify to tc name
  1437.     '0+'     => sub { Scalar::Util::refaddr($_[0]) },
  1438.     '|'      => sub {                  # or-combination
  1439.         require Mouse::Util::TypeConstraints;
  1440.         return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
  1441.             "$_[0] | $_[1]",
  1442.         );
  1443.     },
  1444.  
  1445.     fallback => 1;
  1446.  
  1447. sub new {
  1448.     my $class = shift;
  1449.     my %args  = @_ == 1 ? %{$_[0]} : @_;
  1450.  
  1451.     $args{name} = '__ANON__' if !defined $args{name};
  1452.  
  1453.     my $check = delete $args{optimized};
  1454.  
  1455.     if($check){
  1456.         $args{hand_optimized_type_constraint} = $check;
  1457.         $args{compiled_type_constraint}       = $check;
  1458.     }
  1459.  
  1460.     $check = $args{constraint};
  1461.  
  1462.     if(defined($check) && ref($check) ne 'CODE'){
  1463.         $class->throw_error("Constraint for $args{name} is not a CODE reference");
  1464.     }
  1465.  
  1466.     my $self = bless \%args, $class;
  1467.     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  1468.  
  1469.     $self->_compile_union_type_coercion() if $self->{type_constraints};
  1470.     return $self;
  1471. }
  1472.  
  1473. sub create_child_type{
  1474.     my $self = shift;
  1475.     return ref($self)->new(
  1476.         # a child inherits its parent's attributes
  1477.         %{$self},
  1478.  
  1479.         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  1480.         compiled_type_constraint       => undef,
  1481.         hand_optimized_type_constraint => undef,
  1482.  
  1483.         # and is given child-specific args, of course.
  1484.         @_,
  1485.  
  1486.         # and its parent
  1487.         parent => $self,
  1488.    );
  1489. }
  1490.  
  1491. sub name;
  1492. sub parent;
  1493. sub message;
  1494. sub has_coercion;
  1495.  
  1496. sub check;
  1497.  
  1498. sub type_parameter;
  1499. sub __is_parameterized;
  1500.  
  1501. sub _compiled_type_constraint;
  1502. sub _compiled_type_coercion;
  1503.  
  1504. sub compile_type_constraint;
  1505.  
  1506.  
  1507. sub _add_type_coercions{
  1508.     my $self = shift;
  1509.  
  1510.     my $coercions = ($self->{coercion_map} ||= []);
  1511.     my %has       = map{ $_->[0] => undef } @{$coercions};
  1512.  
  1513.     for(my $i = 0; $i < @_; $i++){
  1514.         my $from   = $_[  $i];
  1515.         my $action = $_[++$i];
  1516.  
  1517.         if(exists $has{$from}){
  1518.             $self->throw_error("A coercion action already exists for '$from'");
  1519.         }
  1520.  
  1521.         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
  1522.             or $self->throw_error("Could not find the type constraint ($from) to coerce from");
  1523.  
  1524.         push @{$coercions}, [ $type => $action ];
  1525.     }
  1526.  
  1527.     # compile
  1528.     if(exists $self->{type_constraints}){ # union type
  1529.         $self->throw_error("Cannot add additional type coercions to Union types");
  1530.     }
  1531.     else{
  1532.         $self->_compile_type_coercion();
  1533.     }
  1534.     return;
  1535. }
  1536.  
  1537. sub _compile_type_coercion {
  1538.     my($self) = @_;
  1539.  
  1540.     my @coercions = @{$self->{coercion_map}};
  1541.  
  1542.     $self->{_compiled_type_coercion} = sub {
  1543.        my($thing) = @_;
  1544.        foreach my $pair (@coercions) {
  1545.             #my ($constraint, $converter) = @$pair;
  1546.             if ($pair->[0]->check($thing)) {
  1547.               local $_ = $thing;
  1548.               return $pair->[1]->($thing);
  1549.             }
  1550.        }
  1551.        return $thing;
  1552.     };
  1553.     return;
  1554. }
  1555.  
  1556. sub _compile_union_type_coercion {
  1557.     my($self) = @_;
  1558.  
  1559.     my @coercions;
  1560.     foreach my $type(@{$self->{type_constraints}}){
  1561.         if($type->has_coercion){
  1562.             push @coercions, $type;
  1563.         }
  1564.     }
  1565.     if(@coercions){
  1566.         $self->{_compiled_type_coercion} = sub {
  1567.             my($thing) = @_;
  1568.             foreach my $type(@coercions){
  1569.                 my $value = $type->coerce($thing);
  1570.                 return $value if $self->check($value);
  1571.             }
  1572.             return $thing;
  1573.         };
  1574.     }
  1575.     return;
  1576. }
  1577.  
  1578. sub coerce {
  1579.     my $self = shift;
  1580.  
  1581.     my $coercion = $self->_compiled_type_coercion;
  1582.     if(!$coercion){
  1583.         $self->throw_error("Cannot coerce without a type coercion");
  1584.     }
  1585.  
  1586.     return $_[0] if $self->check(@_);
  1587.  
  1588.     return  $coercion->(@_);
  1589. }
  1590.  
  1591. sub get_message {
  1592.     my ($self, $value) = @_;
  1593.     if ( my $msg = $self->message ) {
  1594.         local $_ = $value;
  1595.         return $msg->($value);
  1596.     }
  1597.     else {
  1598.         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
  1599.         return "Validation failed for '$self' with value $value";
  1600.     }
  1601. }
  1602.  
  1603. sub is_a_type_of{
  1604.     my($self, $other) = @_;
  1605.  
  1606.     # ->is_a_type_of('__ANON__') is always false
  1607.     return 0 if !ref($other) && $other eq '__ANON__';
  1608.  
  1609.     (my $other_name = $other) =~ s/\s+//g;
  1610.  
  1611.     return 1 if $self->name eq $other_name;
  1612.  
  1613.     if(exists $self->{type_constraints}){ # union
  1614.         foreach my $type(@{$self->{type_constraints}}){
  1615.             return 1 if $type->name eq $other_name;
  1616.         }
  1617.     }
  1618.  
  1619.     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
  1620.         return 1 if $parent->name eq $other_name;
  1621.     }
  1622.  
  1623.     return 0;
  1624. }
  1625.  
  1626. # See also Moose::Meta::TypeConstraint::Parameterizable
  1627. sub parameterize{
  1628.     my($self, $param, $name) = @_;
  1629.  
  1630.     if(!ref $param){
  1631.         require Mouse::Util::TypeConstraints;
  1632.         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
  1633.     }
  1634.  
  1635.     $name ||= sprintf '%s[%s]', $self->name, $param->name;
  1636.  
  1637.     my $generator = $self->{constraint_generator}
  1638.         || $self->throw_error("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
  1639.  
  1640.     return Mouse::Meta::TypeConstraint->new(
  1641.         name           => $name,
  1642.         parent         => $self,
  1643.         type_parameter => $param,
  1644.         constraint     => $generator->($param), # must be 'constraint', not 'optimized'
  1645.     );
  1646. }
  1647.  
  1648. sub assert_valid {
  1649.     my ($self, $value) = @_;
  1650.  
  1651.     if(!$self->check($value)){
  1652.         $self->throw_error($self->get_message($value));
  1653.     }
  1654.     return 1;
  1655. }
  1656.  
  1657. sub throw_error {
  1658.     require Mouse::Meta::Module;
  1659.     goto &Mouse::Meta::Module::throw_error;
  1660. }
  1661.  
  1662. }
  1663. BEGIN{ # lib/Mouse/Util/TypeConstraints.pm
  1664. package Mouse::Util::TypeConstraints;
  1665. use Mouse::Util qw(does_role not_supported); # enables strict and warnings
  1666.  
  1667. use Carp         ();
  1668. use Scalar::Util ();
  1669.  
  1670. use Mouse::Meta::TypeConstraint;
  1671. use Mouse::Exporter;
  1672.  
  1673. Mouse::Exporter->setup_import_methods(
  1674.     as_is => [qw(
  1675.         as where message optimize_as
  1676.         from via
  1677.  
  1678.         type subtype class_type role_type duck_type
  1679.         enum
  1680.         coerce
  1681.  
  1682.         find_type_constraint
  1683.         register_type_constraint
  1684.     )],
  1685. );
  1686.  
  1687. our @CARP_NOT = qw(Mouse::Meta::Attribute);
  1688.  
  1689. my %TYPE;
  1690.  
  1691. # The root type
  1692. $TYPE{Any} = Mouse::Meta::TypeConstraint->new(
  1693.     name => 'Any',
  1694. );
  1695.  
  1696. my @builtins = (
  1697.     # $name    => $parent,   $code,
  1698.  
  1699.     # the base type
  1700.     Item       => 'Any',     undef,
  1701.  
  1702.     # the maybe[] type
  1703.     Maybe      => 'Item',    undef,
  1704.  
  1705.     # value types
  1706.     Undef      => 'Item',    \&Undef,
  1707.     Defined    => 'Item',    \&Defined,
  1708.     Bool       => 'Item',    \&Bool,
  1709.     Value      => 'Defined', \&Value,
  1710.     Str        => 'Value',   \&Str,
  1711.     Num        => 'Str',     \&Num,
  1712.     Int        => 'Num',     \&Int,
  1713.  
  1714.     # ref types
  1715.     Ref        => 'Defined', \&Ref,
  1716.     ScalarRef  => 'Ref',     \&ScalarRef,
  1717.     ArrayRef   => 'Ref',     \&ArrayRef,
  1718.     HashRef    => 'Ref',     \&HashRef,
  1719.     CodeRef    => 'Ref',     \&CodeRef,
  1720.     RegexpRef  => 'Ref',     \&RegexpRef,
  1721.     GlobRef    => 'Ref',     \&GlobRef,
  1722.  
  1723.     # object types
  1724.     FileHandle => 'GlobRef', \&FileHandle,
  1725.     Object     => 'Ref',     \&Object,
  1726.  
  1727.     # special string types
  1728.     ClassName  => 'Str',       \&ClassName,
  1729.     RoleName   => 'ClassName', \&RoleName,
  1730. );
  1731.  
  1732.  
  1733. while (my ($name, $parent, $code) = splice @builtins, 0, 3) {
  1734.     $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
  1735.         name      => $name,
  1736.         parent    => $TYPE{$parent},
  1737.         optimized => $code,
  1738.     );
  1739. }
  1740.  
  1741. # make it parametarizable
  1742.  
  1743. $TYPE{Maybe}   {constraint_generator} = \&_parameterize_Maybe_for;
  1744. $TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
  1745. $TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for;
  1746.  
  1747. # sugars
  1748.  
  1749. sub as          ($) { (as          => $_[0]) } ## no critic
  1750. sub where       (&) { (where       => $_[0]) } ## no critic
  1751. sub message     (&) { (message     => $_[0]) } ## no critic
  1752. sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic
  1753.  
  1754. sub from    { @_ }
  1755. sub via (&) { $_[0] } ## no critic
  1756.  
  1757. # type utilities
  1758.  
  1759. sub optimized_constraints { # DEPRECATED
  1760.     Carp::cluck('optimized_constraints() has been deprecated');
  1761.     return \%TYPE;
  1762. }
  1763.  
  1764. undef @builtins;        # free the allocated memory
  1765. @builtins = keys %TYPE; # reuse it
  1766. sub list_all_builtin_type_constraints { @builtins }
  1767.  
  1768. sub list_all_type_constraints         { keys %TYPE }
  1769.  
  1770. sub _create_type{
  1771.     my $mode = shift;
  1772.  
  1773.     my $name;
  1774.     my %args;
  1775.  
  1776.     if(@_ == 1 && ref $_[0]){   # @_ : { name => $name, where => ... }
  1777.         %args = %{$_[0]};
  1778.     }
  1779.     elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
  1780.         $name = $_[0];
  1781.         %args = %{$_[1]};
  1782.     }
  1783.     elsif(@_ % 2){               # @_ : $name => ( where => ... )
  1784.         ($name, %args) = @_;
  1785.     }
  1786.     else{                        # @_ : (name => $name, where => ...)
  1787.         %args = @_;
  1788.     }
  1789.  
  1790.     if(!defined $name){
  1791.         $name = $args{name};
  1792.     }
  1793.  
  1794.     $args{name} = $name;
  1795.     my $parent;
  1796.     if($mode eq 'subtype'){
  1797.         $parent = delete $args{as};
  1798.         if(!$parent){
  1799.             $parent = delete $args{name};
  1800.             $name   = undef;
  1801.         }
  1802.     }
  1803.  
  1804.     if(defined $name){
  1805.         # set 'package_defined_in' only if it is not a core package
  1806.         my $this = $args{package_defined_in};
  1807.         if(!$this){
  1808.             $this = caller(1);
  1809.             if($this !~ /\A Mouse \b/xms){
  1810.                 $args{package_defined_in} = $this;
  1811.             }
  1812.         }
  1813.  
  1814.         if($TYPE{$name}){
  1815.             my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
  1816.             ($this eq $that) or Carp::croak(
  1817.                 "The type constraint '$name' has already been created in $that and cannot be created again in $this"
  1818.             );
  1819.         }
  1820.     }
  1821.     else{
  1822.         $args{name} = '__ANON__';
  1823.     }
  1824.  
  1825.     $args{constraint} = delete $args{where}        if exists $args{where};
  1826.     $args{optimized}  = delete $args{optimized_as} if exists $args{optimized_as};
  1827.  
  1828.     my $constraint;
  1829.     if($mode eq 'subtype'){
  1830.         $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
  1831.     }
  1832.     else{
  1833.         $constraint = Mouse::Meta::TypeConstraint->new(%args);
  1834.     }
  1835.  
  1836.     if(defined $name){
  1837.         return $TYPE{$name} = $constraint;
  1838.     }
  1839.     else{
  1840.         return $constraint;
  1841.     }
  1842. }
  1843.  
  1844. sub type {
  1845.     return _create_type('type', @_);
  1846. }
  1847.  
  1848. sub subtype {
  1849.     return _create_type('subtype', @_);
  1850. }
  1851.  
  1852. sub coerce {
  1853.     my $type_name = shift;
  1854.  
  1855.     my $type = find_type_constraint($type_name)
  1856.         or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it.");
  1857.  
  1858.     $type->_add_type_coercions(@_);
  1859.     return;
  1860. }
  1861.  
  1862. sub class_type {
  1863.     my($name, $options) = @_;
  1864.     my $class = $options->{class} || $name;
  1865.  
  1866.     # ClassType
  1867.     return _create_type 'subtype', $name => (
  1868.         as           => 'Object',
  1869.         optimized_as => Mouse::Util::generate_isa_predicate_for($class),
  1870.     );
  1871. }
  1872.  
  1873. sub role_type {
  1874.     my($name, $options) = @_;
  1875.     my $role = $options->{role} || $name;
  1876.  
  1877.     # RoleType
  1878.     return _create_type 'subtype', $name => (
  1879.         as           => 'Object',
  1880.         optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
  1881.     );
  1882. }
  1883.  
  1884. sub duck_type {
  1885.     my($name, @methods);
  1886.  
  1887.     if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
  1888.         $name = shift;
  1889.     }
  1890.  
  1891.     @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
  1892.  
  1893.     # DuckType
  1894.     return _create_type 'subtype', $name => (
  1895.         as           => 'Object',
  1896.         optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
  1897.     );
  1898. }
  1899.  
  1900. sub enum {
  1901.     my($name, %valid);
  1902.  
  1903.     if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
  1904.         $name = shift;
  1905.     }
  1906.  
  1907.     %valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);
  1908.  
  1909.     # EnumType
  1910.     return _create_type 'subtype', $name => (
  1911.         as            => 'Str',
  1912.         optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
  1913.     );
  1914. }
  1915.  
  1916. sub _find_or_create_regular_type{
  1917.     my($spec, $create)  = @_;
  1918.  
  1919.     return $TYPE{$spec} if exists $TYPE{$spec};
  1920.  
  1921.     my $meta = Mouse::Util::get_metaclass_by_name($spec);
  1922.  
  1923.     if(!defined $meta){
  1924.         return $create ? class_type($spec) : undef;
  1925.     }
  1926.  
  1927.     if(Mouse::Util::is_a_metarole($meta)){
  1928.         return role_type($spec);
  1929.     }
  1930.     else{
  1931.         return class_type($spec);
  1932.     }
  1933. }
  1934.  
  1935. sub _find_or_create_parameterized_type{
  1936.     my($base, $param) = @_;
  1937.  
  1938.     my $name = sprintf '%s[%s]', $base->name, $param->name;
  1939.  
  1940.     $TYPE{$name} ||= $base->parameterize($param, $name);
  1941. }
  1942.  
  1943. sub _find_or_create_union_type{
  1944.     return if grep{ not defined } @_;
  1945.     my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
  1946.  
  1947.     my $name = join '|', @types;
  1948.  
  1949.     # UnionType
  1950.     $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
  1951.         name              => $name,
  1952.         type_constraints  => \@types,
  1953.     );
  1954. }
  1955.  
  1956. # The type parser
  1957.  
  1958. # param : '[' type ']' | NOTHING
  1959. sub _parse_param {
  1960.     my($c) = @_;
  1961.  
  1962.     if($c->{spec} =~ s/^\[//){
  1963.         my $type = _parse_type($c, 1);
  1964.  
  1965.         if($c->{spec} =~ s/^\]//){
  1966.             return $type;
  1967.         }
  1968.         Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
  1969.     }
  1970.  
  1971.     return undef;
  1972. }
  1973.  
  1974. # name : [\w.:]+
  1975. sub _parse_name {
  1976.     my($c, $create) = @_;
  1977.  
  1978.     if($c->{spec} =~ s/\A ([\w.:]+) //xms){
  1979.         return _find_or_create_regular_type($1, $create);
  1980.     }
  1981.     Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
  1982. }
  1983.  
  1984. # single_type : name param
  1985. sub _parse_single_type {
  1986.     my($c, $create) = @_;
  1987.  
  1988.     my $type  = _parse_name($c, $create);
  1989.     my $param = _parse_param($c);
  1990.  
  1991.     if(defined $type){
  1992.         if(defined $param){
  1993.             return _find_or_create_parameterized_type($type, $param);
  1994.         }
  1995.         else {
  1996.             return $type;
  1997.         }
  1998.     }
  1999.     elsif(defined $param){
  2000.         Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
  2001.     }
  2002.     else{
  2003.         return undef;
  2004.     }
  2005. }
  2006.  
  2007. # type : single_type  ('|' single_type)*
  2008. sub _parse_type {
  2009.     my($c, $create) = @_;
  2010.  
  2011.     my $type = _parse_single_type($c, $create);
  2012.     if($c->{spec}){ # can be an union type
  2013.         my @types;
  2014.         while($c->{spec} =~ s/^\|//){
  2015.             push @types, _parse_single_type($c, $create);
  2016.         }
  2017.         if(@types){
  2018.             return _find_or_create_union_type($type, @types);
  2019.         }
  2020.     }
  2021.     return $type;
  2022. }
  2023.  
  2024.  
  2025. sub find_type_constraint {
  2026.     my($spec) = @_;
  2027.     return $spec if Mouse::Util::is_a_type_constraint($spec);
  2028.     return undef if !defined $spec;
  2029.  
  2030.     $spec =~ s/\s+//g;
  2031.     return $TYPE{$spec};
  2032. }
  2033.  
  2034. sub register_type_constraint {
  2035.     my($constraint) = @_;
  2036.     Carp::croak("No type supplied / type is not a valid type constraint")
  2037.         unless Mouse::Util::is_a_type_constraint($constraint);
  2038.     my $name = $constraint->name;
  2039.     Carp::croak("can't register an unnamed type constraint")
  2040.         unless defined $name;
  2041.     return $TYPE{$name} = $constraint;
  2042. }
  2043.  
  2044. sub find_or_parse_type_constraint {
  2045.     my($spec) = @_;
  2046.     return $spec if Mouse::Util::is_a_type_constraint($spec);
  2047.     return undef if !defined $spec;
  2048.  
  2049.     $spec =~ s/\s+//g;
  2050.     return $TYPE{$spec} || do{
  2051.         my $context = {
  2052.             spec => $spec,
  2053.             orig => $spec,
  2054.         };
  2055.         my $type = _parse_type($context);
  2056.  
  2057.         if($context->{spec}){
  2058.             Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'");
  2059.         }
  2060.         $type;
  2061.     };
  2062. }
  2063.  
  2064. sub find_or_create_does_type_constraint{
  2065.     # XXX: Moose does not register a new role_type, but Mouse does.
  2066.     return find_or_parse_type_constraint(@_) || role_type(@_);
  2067. }
  2068.  
  2069. sub find_or_create_isa_type_constraint {
  2070.     # XXX: Moose does not register a new class_type, but Mouse does.
  2071.     return find_or_parse_type_constraint(@_) || class_type(@_);
  2072. }
  2073.  
  2074. }
  2075. BEGIN{ # lib/Mouse.pm
  2076. package Mouse;
  2077. use 5.006_002;
  2078.  
  2079. use Mouse::Exporter; # enables strict and warnings
  2080.  
  2081. our $VERSION = '0.64';
  2082.  
  2083. use Carp         qw(confess);
  2084. use Scalar::Util qw(blessed);
  2085.  
  2086. use Mouse::Util ();
  2087.  
  2088. use Mouse::Meta::Module;
  2089. use Mouse::Meta::Class;
  2090. use Mouse::Meta::Role;
  2091. use Mouse::Meta::Attribute;
  2092. use Mouse::Object;
  2093. use Mouse::Util::TypeConstraints ();
  2094.  
  2095. Mouse::Exporter->setup_import_methods(
  2096.     as_is => [qw(
  2097.         extends with
  2098.         has
  2099.         before after around
  2100.         override super
  2101.         augment  inner
  2102.     ),
  2103.         \&Scalar::Util::blessed,
  2104.         \&Carp::confess,
  2105.    ],
  2106. );
  2107.  
  2108.  
  2109. sub extends {
  2110.     Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_);
  2111.     return;
  2112. }
  2113.  
  2114. sub with {
  2115.     Mouse::Util::apply_all_roles(scalar(caller), @_);
  2116.     return;
  2117. }
  2118.  
  2119. sub has {
  2120.     my $meta = Mouse::Meta::Class->initialize(scalar caller);
  2121.     my $name = shift;
  2122.  
  2123.     $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
  2124.         if @_ % 2; # odd number of arguments
  2125.  
  2126.     if(ref $name){ # has [qw(foo bar)] => (...)
  2127.         for (@{$name}){
  2128.             $meta->add_attribute($_ => @_);
  2129.         }
  2130.     }
  2131.     else{ # has foo => (...)
  2132.         $meta->add_attribute($name => @_);
  2133.     }
  2134.     return;
  2135. }
  2136.  
  2137. sub before {
  2138.     my $meta = Mouse::Meta::Class->initialize(scalar caller);
  2139.     my $code = pop;
  2140.     for my $name($meta->_collect_methods(@_)) {
  2141.         $meta->add_before_method_modifier($name => $code);
  2142.     }
  2143.     return;
  2144. }
  2145.  
  2146. sub after {
  2147.     my $meta = Mouse::Meta::Class->initialize(scalar caller);
  2148.     my $code = pop;
  2149.     for my $name($meta->_collect_methods(@_)) {
  2150.         $meta->add_after_method_modifier($name => $code);
  2151.     }
  2152.     return;
  2153. }
  2154.  
  2155. sub around {
  2156.     my $meta = Mouse::Meta::Class->initialize(scalar caller);
  2157.     my $code = pop;
  2158.     for my $name($meta->_collect_methods(@_)) {
  2159.         $meta->add_around_method_modifier($name => $code);
  2160.     }
  2161.     return;
  2162. }
  2163.  
  2164. our $SUPER_PACKAGE;
  2165. our $SUPER_BODY;
  2166. our @SUPER_ARGS;
  2167.  
  2168. sub super {
  2169.     # This check avoids a recursion loop - see
  2170.     # t/100_bugs/020_super_recursion.t
  2171.     return if  defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
  2172.     return if !defined $SUPER_BODY;
  2173.     $SUPER_BODY->(@SUPER_ARGS);
  2174. }
  2175.  
  2176. sub override {
  2177.     # my($name, $method) = @_;
  2178.     Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_);
  2179. }
  2180.  
  2181. our %INNER_BODY;
  2182. our %INNER_ARGS;
  2183.  
  2184. sub inner {
  2185.     my $pkg = caller();
  2186.     if ( my $body = $INNER_BODY{$pkg} ) {
  2187.         my $args = $INNER_ARGS{$pkg};
  2188.         local $INNER_ARGS{$pkg};
  2189.         local $INNER_BODY{$pkg};
  2190.         return $body->(@{$args});
  2191.     }
  2192.     else {
  2193.         return;
  2194.     }
  2195. }
  2196.  
  2197. sub augment {
  2198.     #my($name, $method) = @_;
  2199.     Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_);
  2200.     return;
  2201. }
  2202.  
  2203. sub init_meta {
  2204.     shift;
  2205.     my %args = @_;
  2206.  
  2207.     my $class = $args{for_class}
  2208.                     or confess("Cannot call init_meta without specifying a for_class");
  2209.  
  2210.     my $base_class = $args{base_class} || 'Mouse::Object';
  2211.     my $metaclass  = $args{metaclass}  || 'Mouse::Meta::Class';
  2212.  
  2213.     my $meta = $metaclass->initialize($class);
  2214.  
  2215.     $meta->add_method(meta => sub{
  2216.         return $metaclass->initialize(ref($_[0]) || $_[0]);
  2217.     });
  2218.  
  2219.     $meta->superclasses($base_class)
  2220.         unless $meta->superclasses;
  2221.  
  2222.     # make a class type for each Mouse class
  2223.     Mouse::Util::TypeConstraints::class_type($class)
  2224.         unless Mouse::Util::TypeConstraints::find_type_constraint($class);
  2225.  
  2226.     return $meta;
  2227. }
  2228.  
  2229. }
  2230. BEGIN{ # lib/Mouse/Meta/Attribute.pm
  2231. package Mouse::Meta::Attribute;
  2232. use Mouse::Util qw(:meta); # enables strict and warnings
  2233.  
  2234. use Carp ();
  2235.  
  2236. use Mouse::Meta::TypeConstraint;
  2237.  
  2238. my %valid_options = map { $_ => undef } (
  2239.   'accessor',
  2240.   'auto_deref',
  2241.   'builder',
  2242.   'clearer',
  2243.   'coerce',
  2244.   'default',
  2245.   'documentation',
  2246.   'does',
  2247.   'handles',
  2248.   'init_arg',
  2249.   'insertion_order',
  2250.   'is',
  2251.   'isa',
  2252.   'lazy',
  2253.   'lazy_build',
  2254.   'name',
  2255.   'predicate',
  2256.   'reader',
  2257.   'required',
  2258.   'traits',
  2259.   'trigger',
  2260.   'type_constraint',
  2261.   'weak_ref',
  2262.   'writer',
  2263.  
  2264.   # internally used
  2265.   'associated_class',
  2266.   'associated_methods',
  2267.  
  2268.   # Moose defines, but Mouse doesn't
  2269.   #'definition_context',
  2270.   #'initializer',
  2271.  
  2272.   # special case for AttributeHelpers
  2273.   'provides',
  2274.   'curries',
  2275. );
  2276.  
  2277. our @CARP_NOT = qw(Mouse::Meta::Class);
  2278.  
  2279. sub new {
  2280.     my $class = shift;
  2281.     my $name  = shift;
  2282.  
  2283.     my $args  = $class->Mouse::Object::BUILDARGS(@_);
  2284.  
  2285.     $class->_process_options($name, $args);
  2286.  
  2287.     $args->{name} = $name;
  2288.  
  2289.     # check options
  2290.     # (1) known by core
  2291.     my @bad = grep{ !exists $valid_options{$_} } keys %{$args};
  2292.  
  2293.     # (2) known by subclasses
  2294.     if(@bad && $class ne __PACKAGE__){
  2295.         my %valid_attrs = (
  2296.             map { $_ => undef }
  2297.             grep { defined }
  2298.             map { $_->init_arg() }
  2299.             $class->meta->get_all_attributes()
  2300.         );
  2301.         @bad = grep{ !exists $valid_attrs{$_} } @bad;
  2302.     }
  2303.  
  2304.     # (3) bad options found
  2305.     if(@bad){
  2306.         Carp::carp(
  2307.             "Found unknown argument(s) passed to '$name' attribute constructor in '$class': "
  2308.             . Mouse::Util::english_list(@bad));
  2309.     }
  2310.  
  2311.     my $self = bless $args, $class;
  2312.  
  2313.     # extra attributes
  2314.     if($class ne __PACKAGE__){
  2315.         $class->meta->_initialize_object($self, $args);
  2316.     }
  2317.  
  2318.     return $self;
  2319. }
  2320.  
  2321. sub has_read_method      { $_[0]->has_reader || $_[0]->has_accessor }
  2322. sub has_write_method     { $_[0]->has_writer || $_[0]->has_accessor }
  2323.  
  2324. sub _create_args { # DEPRECATED
  2325.     $_[0]->{_create_args} = $_[1] if @_ > 1;
  2326.     $_[0]->{_create_args}
  2327. }
  2328.  
  2329. sub interpolate_class{
  2330.     my($class, $args) = @_;
  2331.  
  2332.     if(my $metaclass = delete $args->{metaclass}){
  2333.         $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass );
  2334.     }
  2335.  
  2336.     my @traits;
  2337.     if(my $traits_ref = delete $args->{traits}){
  2338.  
  2339.         for (my $i = 0; $i < @{$traits_ref}; $i++) {
  2340.             my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1);
  2341.  
  2342.             next if $class->does($trait);
  2343.  
  2344.             push @traits, $trait;
  2345.  
  2346.             # are there options?
  2347.             push @traits, $traits_ref->[++$i]
  2348.                 if ref($traits_ref->[$i+1]);
  2349.         }
  2350.  
  2351.         if (@traits) {
  2352.             $class = Mouse::Meta::Class->create_anon_class(
  2353.                 superclasses => [ $class ],
  2354.                 roles        => \@traits,
  2355.                 cache        => 1,
  2356.             )->name;
  2357.         }
  2358.     }
  2359.  
  2360.     return( $class, @traits );
  2361. }
  2362.  
  2363. sub _coerce_and_verify {
  2364.     #my($self, $value, $instance) = @_;
  2365.     my($self, $value) = @_;
  2366.  
  2367.     my $type_constraint = $self->{type_constraint};
  2368.     return $value if !defined $type_constraint;
  2369.  
  2370.     if ($self->should_coerce && $type_constraint->has_coercion) {
  2371.         $value = $type_constraint->coerce($value);
  2372.     }
  2373.  
  2374.     $self->verify_against_type_constraint($value);
  2375.  
  2376.     return $value;
  2377. }
  2378.  
  2379. sub verify_against_type_constraint {
  2380.     my ($self, $value) = @_;
  2381.  
  2382.     my $type_constraint = $self->{type_constraint};
  2383.     return 1 if !$type_constraint;
  2384.     return 1 if $type_constraint->check($value);
  2385.  
  2386.     $self->_throw_type_constraint_error($value, $type_constraint);
  2387. }
  2388.  
  2389. sub _throw_type_constraint_error {
  2390.     my($self, $value, $type) = @_;
  2391.  
  2392.     $self->throw_error(
  2393.         sprintf q{Attribute (%s) does not pass the type constraint because: %s},
  2394.             $self->name,
  2395.             $type->get_message($value),
  2396.     );
  2397. }
  2398.  
  2399. sub illegal_options_for_inheritance {
  2400.     return qw(is reader writer accessor clearer predicate);
  2401. }
  2402.  
  2403. sub clone_and_inherit_options{
  2404.     my $self = shift;
  2405.     my $args = $self->Mouse::Object::BUILDARGS(@_);
  2406.  
  2407.     foreach my $illegal($self->illegal_options_for_inheritance) {
  2408.         if(exists $args->{$illegal} and exists $self->{$illegal}) {
  2409.             $self->throw_error("Illegal inherited option: $illegal");
  2410.         }
  2411.     }
  2412.  
  2413.     foreach my $name(keys %{$self}){
  2414.         if(!exists $args->{$name}){
  2415.             $args->{$name} = $self->{$name}; # inherit from self
  2416.         }
  2417.     }
  2418.  
  2419.     my($attribute_class, @traits) = ref($self)->interpolate_class($args);
  2420.     $args->{traits} = \@traits if @traits;
  2421.  
  2422.     # remove temporary caches
  2423.     foreach my $attr(keys %{$args}){
  2424.         if($attr =~ /\A _/xms){
  2425.             delete $args->{$attr};
  2426.         }
  2427.     }
  2428.  
  2429.     # remove default if lazy_build => 1
  2430.     if($args->{lazy_build}) {
  2431.         delete $args->{default};
  2432.     }
  2433.  
  2434.     return $attribute_class->new($self->name, $args);
  2435. }
  2436.  
  2437. sub get_read_method {
  2438.     return $_[0]->reader || $_[0]->accessor
  2439. }
  2440. sub get_write_method {
  2441.     return $_[0]->writer || $_[0]->accessor
  2442. }
  2443.  
  2444. sub _get_accessor_method_ref {
  2445.     my($self, $type, $generator) = @_;
  2446.  
  2447.     my $metaclass = $self->associated_class
  2448.         || $self->throw_error('No asocciated class for ' . $self->name);
  2449.  
  2450.     my $accessor = $self->$type();
  2451.     if($accessor){
  2452.         return $metaclass->get_method_body($accessor);
  2453.     }
  2454.     else{
  2455.         return $self->accessor_metaclass->$generator($self, $metaclass);
  2456.     }
  2457. }
  2458.  
  2459. sub get_read_method_ref{
  2460.     my($self) = @_;
  2461.     return $self->{_read_method_ref} ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
  2462. }
  2463.  
  2464. sub get_write_method_ref{
  2465.     my($self) = @_;
  2466.     return $self->{_write_method_ref} ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
  2467. }
  2468.  
  2469. sub set_value {
  2470.     my($self, $object, $value) = @_;
  2471.     return $self->get_write_method_ref()->($object, $value);
  2472. }
  2473.  
  2474. sub get_value {
  2475.     my($self, $object) = @_;
  2476.     return $self->get_read_method_ref()->($object);
  2477. }
  2478.  
  2479. sub has_value {
  2480.     my($self, $object) = @_;
  2481.     my $accessor_ref = $self->{_predicate_ref}
  2482.         ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');
  2483.  
  2484.     return $accessor_ref->($object);
  2485. }
  2486.  
  2487. sub clear_value {
  2488.     my($self, $object) = @_;
  2489.     my $accessor_ref = $self->{_crealer_ref}
  2490.         ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer');
  2491.  
  2492.     return $accessor_ref->($object);
  2493. }
  2494.  
  2495.  
  2496. sub associate_method{
  2497.     #my($attribute, $method_name) = @_;
  2498.     my($attribute) = @_;
  2499.     $attribute->{associated_methods}++;
  2500.     return;
  2501. }
  2502.  
  2503. sub install_accessors{
  2504.     my($attribute) = @_;
  2505.  
  2506.     my $metaclass      = $attribute->associated_class;
  2507.     my $accessor_class = $attribute->accessor_metaclass;
  2508.  
  2509.     foreach my $type(qw(accessor reader writer predicate clearer)){
  2510.         if(exists $attribute->{$type}){
  2511.             my $generator = '_generate_' . $type;
  2512.             my $code      = $accessor_class->$generator($attribute, $metaclass);
  2513.             $metaclass->add_method($attribute->{$type} => $code);
  2514.             $attribute->associate_method($attribute->{$type});
  2515.         }
  2516.     }
  2517.  
  2518.     # install delegation
  2519.     if(exists $attribute->{handles}){
  2520.         my %handles = $attribute->_canonicalize_handles($attribute->{handles});
  2521.  
  2522.         while(my($handle, $method_to_call) = each %handles){
  2523.             if($metaclass->has_method($handle)) {
  2524.                 $attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation");
  2525.             }
  2526.  
  2527.             $metaclass->add_method($handle =>
  2528.                 $attribute->_make_delegation_method(
  2529.                     $handle, $method_to_call));
  2530.  
  2531.             $attribute->associate_method($handle);
  2532.         }
  2533.     }
  2534.  
  2535.     return;
  2536. }
  2537.  
  2538. sub delegation_metaclass() { ## no critic
  2539.     'Mouse::Meta::Method::Delegation'
  2540. }
  2541.  
  2542. sub _canonicalize_handles {
  2543.     my($self, $handles) = @_;
  2544.  
  2545.     if (ref($handles) eq 'HASH') {
  2546.         return %$handles;
  2547.     }
  2548.     elsif (ref($handles) eq 'ARRAY') {
  2549.         return map { $_ => $_ } @$handles;
  2550.     }
  2551.     elsif ( ref($handles) eq 'CODE' ) {
  2552.         my $class_or_role = ( $self->{isa} || $self->{does} )
  2553.             || $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name );
  2554.         return $handles->( $self, Mouse::Meta::Class->initialize("$class_or_role"));
  2555.     }
  2556.     elsif (ref($handles) eq 'Regexp') {
  2557.         my $class_or_role = ($self->{isa} || $self->{does})
  2558.             || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");
  2559.  
  2560.         my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
  2561.         return map  { $_ => $_ }
  2562.                grep { !Mouse::Object->can($_) && $_ =~ $handles }
  2563.                    Mouse::Util::is_a_metarole($meta)
  2564.                         ? $meta->get_method_list
  2565.                         : $meta->get_all_method_names;
  2566.     }
  2567.     else {
  2568.         $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
  2569.     }
  2570. }
  2571.  
  2572. sub _make_delegation_method {
  2573.     my($self, $handle, $method_to_call) = @_;
  2574.     return Mouse::Util::load_class($self->delegation_metaclass)
  2575.         ->_generate_delegation($self, $handle, $method_to_call);
  2576. }
  2577.  
  2578. sub throw_error{
  2579.     my $self = shift;
  2580.  
  2581.     my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class';
  2582.     $metaclass->throw_error(@_, depth => 1);
  2583. }
  2584.  
  2585. }
  2586. BEGIN{ # lib/Mouse/Meta/Class.pm
  2587. package Mouse::Meta::Class;
  2588. use Mouse::Util qw/:meta get_linear_isa not_supported/; # enables strict and warnings
  2589.  
  2590. use Scalar::Util qw/blessed weaken/;
  2591.  
  2592. use Mouse::Meta::Module;
  2593. our @ISA = qw(Mouse::Meta::Module);
  2594.  
  2595. our @CARP_NOT = qw(Mouse); # trust Mouse
  2596.  
  2597. sub attribute_metaclass;
  2598. sub method_metaclass;
  2599.  
  2600. sub constructor_class;
  2601. sub destructor_class;
  2602.  
  2603.  
  2604. sub _construct_meta {
  2605.     my($class, %args) = @_;
  2606.  
  2607.     $args{attributes} = {};
  2608.     $args{methods}    = {};
  2609.     $args{roles}      = [];
  2610.  
  2611.     $args{superclasses} = do {
  2612.         no strict 'refs';
  2613.         \@{ $args{package} . '::ISA' };
  2614.     };
  2615.  
  2616.     my $self = bless \%args, ref($class) || $class;
  2617.     if(ref($self) ne __PACKAGE__){
  2618.         $self->meta->_initialize_object($self, \%args);
  2619.     }
  2620.     return $self;
  2621. }
  2622.  
  2623. sub create_anon_class{
  2624.     my $self = shift;
  2625.     return $self->create(undef, @_);
  2626. }
  2627.  
  2628. sub is_anon_class;
  2629.  
  2630. sub roles;
  2631.  
  2632. sub calculate_all_roles {
  2633.     my $self = shift;
  2634.     my %seen;
  2635.     return grep { !$seen{ $_->name }++ }
  2636.            map  { $_->calculate_all_roles } @{ $self->roles };
  2637. }
  2638.  
  2639. sub superclasses {
  2640.     my $self = shift;
  2641.  
  2642.     if (@_) {
  2643.         foreach my $super(@_){
  2644.             Mouse::Util::load_class($super);
  2645.             my $meta = Mouse::Util::get_metaclass_by_name($super);
  2646.  
  2647.             next if not defined $meta;
  2648.  
  2649.             if(Mouse::Util::is_a_metarole($meta)){
  2650.                 $self->throw_error("You cannot inherit from a Mouse Role ($super)");
  2651.             }
  2652.  
  2653.             next if $self->isa(ref $meta); # _superclass_meta_is_compatible
  2654.  
  2655.             $self->_reconcile_with_superclass_meta($meta);
  2656.         }
  2657.         @{ $self->{superclasses} } = @_;
  2658.     }
  2659.  
  2660.     return @{ $self->{superclasses} };
  2661. }
  2662. my @MetaClassTypes = (
  2663.     'attribute',   # Mouse::Meta::Attribute
  2664.     'method',      # Mouse::Meta::Method
  2665.     'constructor', # Mouse::Meta::Method::Constructor
  2666.     'destructor',  # Mouse::Meta::Method::Destructor
  2667. );
  2668.  
  2669. sub _reconcile_with_superclass_meta {
  2670.     my($self, $other) = @_;
  2671.  
  2672.     # find incompatible traits
  2673.     my %metaroles;
  2674.     foreach my $metaclass_type(@MetaClassTypes){
  2675.         my $accessor = $self->can($metaclass_type . '_metaclass')
  2676.             || $self->can($metaclass_type . '_class');
  2677.  
  2678.         my $other_c = $other->$accessor();
  2679.         my $self_c  = $self->$accessor();
  2680.  
  2681.         if(!$self_c->isa($other_c)){
  2682.             $metaroles{$metaclass_type}
  2683.                 = [ $self_c->meta->_collect_roles($other_c->meta) ];
  2684.         }
  2685.     }
  2686.  
  2687.     $metaroles{class} = [$self->meta->_collect_roles($other->meta)];
  2688.  
  2689.     #use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump;
  2690.  
  2691.     require Mouse::Util::MetaRole;
  2692.     $_[0] = Mouse::Util::MetaRole::apply_metaroles(
  2693.         for             => $self,
  2694.         class_metaroles => \%metaroles,
  2695.     );
  2696.     return;
  2697. }
  2698.  
  2699. sub _collect_roles {
  2700.     my ($self, $other) = @_;
  2701.  
  2702.     # find common ancestor
  2703.     my @self_lin_isa  = $self->linearized_isa;
  2704.     my @other_lin_isa = $other->linearized_isa;
  2705.  
  2706.     my(@self_anon_supers, @other_anon_supers);
  2707.     push @self_anon_supers,  shift @self_lin_isa  while $self_lin_isa[0]->meta->is_anon_class;
  2708.     push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class;
  2709.  
  2710.     my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0];
  2711.  
  2712.     if(!$common_ancestor){
  2713.         $self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility',
  2714.             $self->name, $other->name);
  2715.     }
  2716.  
  2717.     my %seen;
  2718.     return sort grep { !$seen{$_}++ } ## no critic
  2719.         (map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers),
  2720.         (map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers),
  2721.     ;
  2722. }
  2723.  
  2724.  
  2725. sub find_method_by_name{
  2726.     my($self, $method_name) = @_;
  2727.     defined($method_name)
  2728.         or $self->throw_error('You must define a method name to find');
  2729.  
  2730.     foreach my $class( $self->linearized_isa ){
  2731.         my $method = $self->initialize($class)->get_method($method_name);
  2732.         return $method if defined $method;
  2733.     }
  2734.     return undef;
  2735. }
  2736.  
  2737. sub get_all_methods {
  2738.     my($self) = @_;
  2739.     return map{ $self->find_method_by_name($_) } $self->get_all_method_names;
  2740. }
  2741.  
  2742. sub get_all_method_names {
  2743.     my $self = shift;
  2744.     my %uniq;
  2745.     return grep { $uniq{$_}++ == 0 }
  2746.             map { Mouse::Meta::Class->initialize($_)->get_method_list() }
  2747.             $self->linearized_isa;
  2748. }
  2749.  
  2750. sub find_attribute_by_name{
  2751.     my($self, $name) = @_;
  2752.     my $attr;
  2753.     foreach my $class($self->linearized_isa){
  2754.         my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
  2755.         $attr = $meta->get_attribute($name) and last;
  2756.     }
  2757.     return $attr;
  2758. }
  2759.  
  2760. sub add_attribute {
  2761.     my $self = shift;
  2762.  
  2763.     my($attr, $name);
  2764.  
  2765.     if(blessed $_[0]){
  2766.         $attr = $_[0];
  2767.  
  2768.         $attr->isa('Mouse::Meta::Attribute')
  2769.             || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)");
  2770.  
  2771.         $name = $attr->name;
  2772.     }
  2773.     else{
  2774.         # _process_attribute
  2775.         $name = shift;
  2776.  
  2777.         my %args = (@_ == 1) ? %{$_[0]} : @_;
  2778.  
  2779.         defined($name)
  2780.             or $self->throw_error('You must provide a name for the attribute');
  2781.  
  2782.         if ($name =~ s/^\+//) { # inherited attributes
  2783.             my $inherited_attr = $self->find_attribute_by_name($name)
  2784.                 or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name);
  2785.  
  2786.             $attr = $inherited_attr->clone_and_inherit_options(%args);
  2787.         }
  2788.         else{
  2789.             my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
  2790.             $args{traits} = \@traits if @traits;
  2791.  
  2792.             $attr = $attribute_class->new($name, %args);
  2793.         }
  2794.     }
  2795.  
  2796.     weaken( $attr->{associated_class} = $self );
  2797.  
  2798.     # install accessors first
  2799.     $attr->install_accessors();
  2800.  
  2801.     # then register the attribute to the metaclass
  2802.     $attr->{insertion_order} = keys %{ $self->{attributes} };
  2803.     $self->{attributes}{$attr->name} = $attr;
  2804.  
  2805.     if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
  2806.         Carp::carp(qq{Attribute ($name) of class }.$self->name
  2807.             .qq{ has no associated methods (did you mean to provide an "is" argument?)});
  2808.     }
  2809.     return $attr;
  2810. }
  2811.  
  2812. sub compute_all_applicable_attributes { # DEPRECATED
  2813.     Carp::cluck('compute_all_applicable_attributes() has been deprecated. Use get_all_attributes() instead');
  2814.  
  2815.     return shift->get_all_attributes(@_)
  2816. }
  2817.  
  2818. sub linearized_isa;
  2819.  
  2820. sub new_object;
  2821. sub clone_object;
  2822.  
  2823.  
  2824. sub clone_instance { # DEPRECATED
  2825.     my ($class, $instance, %params) = @_;
  2826.  
  2827.     Carp::cluck('clone_instance() has been deprecated. Use clone_object() instead');
  2828.  
  2829.     return $class->clone_object($instance, %params);
  2830. }
  2831.  
  2832.  
  2833. sub immutable_options {
  2834.     my ( $self, @args ) = @_;
  2835.  
  2836.     return (
  2837.         inline_constructor => 1,
  2838.         inline_destructor  => 1,
  2839.         constructor_name   => 'new',
  2840.         @args,
  2841.     );
  2842. }
  2843.  
  2844.  
  2845. sub make_immutable {
  2846.     my $self = shift;
  2847.     my %args = $self->immutable_options(@_);
  2848.  
  2849.     $self->{is_immutable}++;
  2850.  
  2851.     if ($args{inline_constructor}) {
  2852.         $self->add_method($args{constructor_name} =>
  2853.             Mouse::Util::load_class($self->constructor_class)
  2854.                 ->_generate_constructor($self, \%args));
  2855.     }
  2856.  
  2857.     if ($args{inline_destructor}) {
  2858.         $self->add_method(DESTROY =>
  2859.             Mouse::Util::load_class($self->destructor_class)
  2860.                 ->_generate_destructor($self, \%args));
  2861.     }
  2862.  
  2863.     # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
  2864.     # at the end of a source file. 
  2865.     return 1;
  2866. }
  2867.  
  2868. sub make_mutable {
  2869.     my($self) = @_;
  2870.     $self->{is_immutable} = 0;
  2871.     return;
  2872. }
  2873.  
  2874. sub is_immutable;
  2875. sub is_mutable   { !$_[0]->is_immutable }
  2876.  
  2877. sub _install_modifier_pp{
  2878.     my( $self, $type, $name, $code ) = @_;
  2879.     my $into = $self->name;
  2880.  
  2881.     my $original = $into->can($name)
  2882.         or $self->throw_error("The method '$name' is not found in the inheritance hierarchy for class $into");
  2883.  
  2884.     my $modifier_table = $self->{modifiers}{$name};
  2885.  
  2886.     if(!$modifier_table){
  2887.         my(@before, @after, @around, $cache, $modified);
  2888.  
  2889.         $cache = $original;
  2890.  
  2891.         $modified = sub {
  2892.             for my $c (@before) { $c->(@_) }
  2893.  
  2894.             if(wantarray){ # list context
  2895.                 my @rval = $cache->(@_);
  2896.  
  2897.                 for my $c(@after){ $c->(@_) }
  2898.                 return @rval;
  2899.             }
  2900.             elsif(defined wantarray){ # scalar context
  2901.                 my $rval = $cache->(@_);
  2902.  
  2903.                 for my $c(@after){ $c->(@_) }
  2904.                 return $rval;
  2905.             }
  2906.             else{ # void context
  2907.                 $cache->(@_);
  2908.  
  2909.                 for my $c(@after){ $c->(@_) }
  2910.                 return;
  2911.             }
  2912.         };
  2913.  
  2914.         $self->{modifiers}{$name} = $modifier_table = {
  2915.             original => $original,
  2916.  
  2917.             before   => \@before,
  2918.             after    => \@after,
  2919.             around   => \@around,
  2920.  
  2921.             cache    => \$cache, # cache for around modifiers
  2922.         };
  2923.  
  2924.         $self->add_method($name => $modified);
  2925.     }
  2926.  
  2927.     if($type eq 'before'){
  2928.         unshift @{$modifier_table->{before}}, $code;
  2929.     }
  2930.     elsif($type eq 'after'){
  2931.         push @{$modifier_table->{after}}, $code;
  2932.     }
  2933.     else{ # around
  2934.         push @{$modifier_table->{around}}, $code;
  2935.  
  2936.         my $next = ${ $modifier_table->{cache} };
  2937.         ${ $modifier_table->{cache} } = sub{ $code->($next, @_) };
  2938.     }
  2939.  
  2940.     return;
  2941. }
  2942.  
  2943. sub _install_modifier {
  2944.     my ( $self, $type, $name, $code ) = @_;
  2945.  
  2946.     # load Data::Util first
  2947.     my $no_cmm_fast = do{
  2948.         local $@;
  2949.         eval q{ use Data::Util 0.55 () };
  2950.         $@;
  2951.     };
  2952.  
  2953.     my $impl;
  2954.     if($no_cmm_fast){
  2955.         $impl = \&_install_modifier_pp;
  2956.     }
  2957.     else{
  2958.         $impl = sub {
  2959.             my ( $self, $type, $name, $code ) = @_;
  2960.             my $into = $self->name;
  2961.  
  2962.             my $method = Mouse::Util::get_code_ref( $into, $name );
  2963.  
  2964.             if ( !$method || !Data::Util::subroutine_modifier($method) ) {
  2965.                 unless ($method) {
  2966.                     $method = $into->can($name)
  2967.                         or Carp::confess("The method '$name' is not found in the inheritance hierarchy for class $into");
  2968.                 }
  2969.                 $method = Data::Util::modify_subroutine( $method,
  2970.                     $type => [$code] );
  2971.  
  2972.                 $self->add_method($name => $method);
  2973.             }
  2974.             else {
  2975.                 Data::Util::subroutine_modifier( $method, $type => $code );
  2976.                 $self->add_method($name => Mouse::Util::get_code_ref($into, $name));
  2977.             }
  2978.  
  2979.             return;
  2980.         };
  2981.     }
  2982.  
  2983.     # replace this method itself :)
  2984.     {
  2985.         no warnings 'redefine';
  2986.         *_install_modifier = $impl;
  2987.     }
  2988.  
  2989.     $self->$impl( $type, $name, $code );
  2990. }
  2991.  
  2992. sub add_before_method_modifier {
  2993.     my ( $self, $name, $code ) = @_;
  2994.     $self->_install_modifier( 'before', $name, $code );
  2995. }
  2996.  
  2997. sub add_around_method_modifier {
  2998.     my ( $self, $name, $code ) = @_;
  2999.     $self->_install_modifier( 'around', $name, $code );
  3000. }
  3001.  
  3002. sub add_after_method_modifier {
  3003.     my ( $self, $name, $code ) = @_;
  3004.     $self->_install_modifier( 'after', $name, $code );
  3005. }
  3006.  
  3007. sub add_override_method_modifier {
  3008.     my ($self, $name, $code) = @_;
  3009.  
  3010.     if($self->has_method($name)){
  3011.         $self->throw_error("Cannot add an override method if a local method is already present");
  3012.     }
  3013.  
  3014.     my $package = $self->name;
  3015.  
  3016.     my $super_body = $package->can($name)
  3017.         or $self->throw_error("You cannot override '$name' because it has no super method");
  3018.  
  3019.     $self->add_method($name => sub {
  3020.         local $Mouse::SUPER_PACKAGE = $package;
  3021.         local $Mouse::SUPER_BODY    = $super_body;
  3022.         local @Mouse::SUPER_ARGS    = @_;
  3023.  
  3024.         $code->(@_);
  3025.     });
  3026.     return;
  3027. }
  3028.  
  3029. sub add_augment_method_modifier {
  3030.     my ($self, $name, $code) = @_;
  3031.     if($self->has_method($name)){
  3032.         $self->throw_error("Cannot add an augment method if a local method is already present");
  3033.     }
  3034.  
  3035.     my $super = $self->find_method_by_name($name)
  3036.         or $self->throw_error("You cannot augment '$name' because it has no super method");
  3037.  
  3038.     my $super_package = $super->package_name;
  3039.     my $super_body    = $super->body;
  3040.  
  3041.     $self->add_method($name => sub{
  3042.         local $Mouse::INNER_BODY{$super_package} = $code;
  3043.         local $Mouse::INNER_ARGS{$super_package} = [@_];
  3044.         $super_body->(@_);
  3045.     });
  3046.     return;
  3047. }
  3048.  
  3049. sub does_role {
  3050.     my ($self, $role_name) = @_;
  3051.  
  3052.     (defined $role_name)
  3053.         || $self->throw_error("You must supply a role name to look for");
  3054.  
  3055.     $role_name = $role_name->name if ref $role_name;
  3056.  
  3057.     for my $class ($self->linearized_isa) {
  3058.         my $meta = Mouse::Util::get_metaclass_by_name($class)
  3059.             or next;
  3060.  
  3061.         for my $role (@{ $meta->roles }) {
  3062.  
  3063.             return 1 if $role->does_role($role_name);
  3064.         }
  3065.     }
  3066.  
  3067.     return 0;
  3068. }
  3069.  
  3070. }
  3071. BEGIN{ # lib/Mouse/Meta/Method.pm
  3072. package Mouse::Meta::Method;
  3073. use Mouse::Util qw(:meta); # enables strict and warnings
  3074. use Scalar::Util ();
  3075.  
  3076. use overload
  3077.     '=='  => '_equal',
  3078.     'eq'  => '_equal',
  3079.     '&{}' => sub{ $_[0]->body },
  3080.     fallback => 1,
  3081. ;
  3082.  
  3083. sub wrap{
  3084.     my $class = shift;
  3085.  
  3086.     return $class->_new(@_);
  3087. }
  3088.  
  3089. sub _new{
  3090.     my($class, %args) = @_;
  3091.     my $self = bless \%args, $class;
  3092.  
  3093.     if($class ne __PACKAGE__){
  3094.         $self->meta->_initialize_object($self, \%args);
  3095.     }
  3096.     return $self;
  3097. }
  3098.  
  3099. sub body                 { $_[0]->{body}    }
  3100. sub name                 { $_[0]->{name}    }
  3101. sub package_name         { $_[0]->{package} }
  3102. sub associated_metaclass { $_[0]->{associated_metaclass} }
  3103.  
  3104. sub fully_qualified_name {
  3105.     my($self) = @_;
  3106.     return $self->package_name . '::' . $self->name;
  3107. }
  3108.  
  3109. # for Moose compat
  3110. sub _equal {
  3111.     my($l, $r) = @_;
  3112.  
  3113.     return Scalar::Util::blessed($r)
  3114.             && $l->body         == $r->body
  3115.             && $l->name         eq $r->name
  3116.             && $l->package_name eq $r->package_name;
  3117. }
  3118.  
  3119. }
  3120. BEGIN{ # lib/Mouse/Meta/Method/Accessor.pm
  3121. package Mouse::Meta::Method::Accessor;
  3122. use Mouse::Util qw(:meta); # enables strict and warnings
  3123.  
  3124. sub _inline_slot{
  3125.     my(undef, $self_var, $attr_name) = @_;
  3126.     return sprintf '%s->{q{%s}}', $self_var, $attr_name;
  3127. }
  3128.  
  3129. sub _generate_accessor_any{
  3130.     my($method_class, $type, $attribute, $class) = @_;
  3131.  
  3132.     my $name          = $attribute->name;
  3133.     my $default       = $attribute->default;
  3134.     my $constraint    = $attribute->type_constraint;
  3135.     my $builder       = $attribute->builder;
  3136.     my $trigger       = $attribute->trigger;
  3137.     my $is_weak       = $attribute->is_weak_ref;
  3138.     my $should_deref  = $attribute->should_auto_deref;
  3139.     my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce);
  3140.  
  3141.     my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef;
  3142.  
  3143.     my $self  = '$_[0]';
  3144.     my $slot  = $method_class->_inline_slot($self, $name);;
  3145.  
  3146.     my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__)
  3147.                  . "sub {\n";
  3148.  
  3149.     if ($type eq 'rw' || $type eq 'wo') {
  3150.         if($type eq 'rw'){
  3151.             $accessor .= 
  3152.                 'if (scalar(@_) >= 2) {' . "\n";
  3153.         }
  3154.         else{ # writer
  3155.             $accessor .= 
  3156.                 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
  3157.                 '{' . "\n";
  3158.         }
  3159.                 
  3160.         my $value = '$_[1]';
  3161.  
  3162.         if (defined $constraint) {
  3163.             if ($should_coerce) {
  3164.                 $accessor .=
  3165.                     "\n".
  3166.                     'my $val = $constraint->coerce('.$value.');';
  3167.                 $value = '$val';
  3168.             }
  3169.             $accessor .= 
  3170.                 "\n".
  3171.                 '$compiled_type_constraint->('.$value.') or
  3172.                     $attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n";
  3173.         }
  3174.  
  3175.         # if there's nothing left to do for the attribute we can return during
  3176.         # this setter
  3177.         $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
  3178.  
  3179.         $accessor .= "$slot = $value;\n";
  3180.  
  3181.         if ($is_weak) {
  3182.             $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
  3183.         }
  3184.  
  3185.         if ($trigger) {
  3186.             $accessor .= '$trigger->('.$self.', '.$value.');' . "\n";
  3187.         }
  3188.  
  3189.         $accessor .= "}\n";
  3190.     }
  3191.     elsif($type eq 'ro') {
  3192.         $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n";
  3193.     }
  3194.     else{
  3195.         $class->throw_error("Unknown accessor type '$type'");
  3196.     }
  3197.  
  3198.     if ($attribute->is_lazy and $type ne 'wo') {
  3199.         my $value;
  3200.  
  3201.         if (defined $builder){
  3202.             $value = "$self->\$builder()";
  3203.         }
  3204.         elsif (ref($default) eq 'CODE'){
  3205.             $value = "$self->\$default()";
  3206.         }
  3207.         else{
  3208.             $value = '$default';
  3209.         }
  3210.  
  3211.         $accessor .= "els" if $type eq 'rw';
  3212.         $accessor .= "if(!exists $slot){\n";
  3213.         if($should_coerce){
  3214.             $accessor .= "$slot = \$constraint->coerce($value)";
  3215.         }
  3216.         elsif(defined $constraint){
  3217.             $accessor .= "my \$tmp = $value;\n";
  3218.  
  3219.             $accessor .= "\$compiled_type_constraint->(\$tmp)";
  3220.             $accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n";
  3221.             $accessor .= "$slot = \$tmp;\n";
  3222.         }
  3223.         else{
  3224.             $accessor .= "$slot = $value;\n";
  3225.         }
  3226.         if ($is_weak) {
  3227.             $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
  3228.         }
  3229.         $accessor .= "}\n";
  3230.     }
  3231.  
  3232.     if ($should_deref) {
  3233.         if ($constraint->is_a_type_of('ArrayRef')) {
  3234.             $accessor .= "return \@{ $slot || [] } if wantarray;\n";
  3235.         }
  3236.         elsif($constraint->is_a_type_of('HashRef')){
  3237.             $accessor .= "return \%{ $slot || {} } if wantarray;\n";
  3238.         }
  3239.         else{
  3240.             $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name);
  3241.         }
  3242.     }
  3243.  
  3244.     $accessor .= "return $slot;\n}\n";
  3245.  
  3246.     #print $accessor, "\n";
  3247.     my $code;
  3248.     my $e = do{
  3249.         local $@;
  3250.         $code = eval $accessor;
  3251.         $@;
  3252.     };
  3253.     die $e if $e;
  3254.  
  3255.     return $code;
  3256. }
  3257.  
  3258. sub _generate_accessor{
  3259.     #my($self, $attribute, $metaclass) = @_;
  3260.     my $self = shift;
  3261.     return $self->_generate_accessor_any(rw => @_);
  3262. }
  3263.  
  3264. sub _generate_reader {
  3265.     #my($self, $attribute, $metaclass) = @_;
  3266.     my $self = shift;
  3267.     return $self->_generate_accessor_any(ro => @_);
  3268. }
  3269.  
  3270. sub _generate_writer {
  3271.     #my($self, $attribute, $metaclass) = @_;
  3272.     my $self = shift;
  3273.     return $self->_generate_accessor_any(wo => @_);
  3274. }
  3275.  
  3276. sub _generate_predicate {
  3277.     #my($self, $attribute, $metaclass) = @_;
  3278.     my(undef, $attribute) = @_;
  3279.  
  3280.     my $slot = $attribute->name;
  3281.     return sub{
  3282.         return exists $_[0]->{$slot};
  3283.     };
  3284. }
  3285.  
  3286. sub _generate_clearer {
  3287.     #my($self, $attribute, $metaclass) = @_;
  3288.     my(undef, $attribute) = @_;
  3289.  
  3290.     my $slot = $attribute->name;
  3291.     return sub{
  3292.         delete $_[0]->{$slot};
  3293.     };
  3294. }
  3295.  
  3296. }
  3297. BEGIN{ # lib/Mouse/Meta/Method/Constructor.pm
  3298. package Mouse::Meta::Method::Constructor;
  3299. use Mouse::Util qw(:meta); # enables strict and warnings
  3300.  
  3301. sub _inline_slot{
  3302.     my(undef, $self_var, $attr_name) = @_;
  3303.     return sprintf '%s->{q{%s}}', $self_var, $attr_name;
  3304. }
  3305.  
  3306. sub _generate_constructor {
  3307.     my ($class, $metaclass, $args) = @_;
  3308.  
  3309.     my $associated_metaclass_name = $metaclass->name;
  3310.  
  3311.     my @attrs         = $metaclass->get_all_attributes;
  3312.  
  3313.     my $buildall      = $class->_generate_BUILDALL($metaclass);
  3314.     my $buildargs     = $class->_generate_BUILDARGS($metaclass);
  3315.     my $processattrs  = $class->_generate_processattrs($metaclass, \@attrs);
  3316.  
  3317.     my @checks = map { $_ && $_->_compiled_type_constraint }
  3318.                  map { $_->type_constraint } @attrs;
  3319.  
  3320.     my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
  3321.         sub \{
  3322.             my \$class = shift;
  3323.             return \$class->Mouse::Object::new(\@_)
  3324.                 if \$class ne q{$associated_metaclass_name};
  3325.             # BUILDARGS
  3326.             $buildargs;
  3327.             my \$instance = bless {}, \$class;
  3328.             # process attributes
  3329.             $processattrs;
  3330.             # BUILDALL
  3331.             $buildall;
  3332.             return \$instance;
  3333.         }
  3334. ...
  3335.     #warn $source;
  3336.     my $code;
  3337.     my $e = do{
  3338.         local $@;
  3339.         $code = eval $source;
  3340.         $@;
  3341.     };
  3342.     die $e if $e;
  3343.     return $code;
  3344. }
  3345.  
  3346. sub _generate_processattrs {
  3347.     my ($method_class, $metaclass, $attrs) = @_;
  3348.     my @res;
  3349.  
  3350.     my $has_triggers;
  3351.     my $strict = $metaclass->strict_constructor;
  3352.  
  3353.     if($strict){
  3354.         push @res, 'my $used = 0;';
  3355.     }
  3356.  
  3357.     for my $index (0 .. @$attrs - 1) {
  3358.         my $code = '';
  3359.  
  3360.         my $attr = $attrs->[$index];
  3361.         my $key  = $attr->name;
  3362.  
  3363.         my $init_arg        = $attr->init_arg;
  3364.         my $type_constraint = $attr->type_constraint;
  3365.         my $is_weak_ref     = $attr->is_weak_ref;
  3366.         my $need_coercion;
  3367.  
  3368.         my $instance_slot  = $method_class->_inline_slot('$instance', $key);
  3369.         my $attr_var       = "\$attrs[$index]";
  3370.         my $constraint_var;
  3371.  
  3372.         if(defined $type_constraint){
  3373.              $constraint_var = "$attr_var\->{type_constraint}";
  3374.              $need_coercion  = ($attr->should_coerce && $type_constraint->has_coercion);
  3375.         }
  3376.  
  3377.         $code .= "# initialize $key\n";
  3378.  
  3379.         my $post_process = '';
  3380.         if(defined $type_constraint){
  3381.             $post_process .= "\$checks[$index]->($instance_slot)";
  3382.             $post_process .= "  or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
  3383.         }
  3384.         if($is_weak_ref){
  3385.             $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n";
  3386.         }
  3387.  
  3388.         if (defined $init_arg) {
  3389.             my $value = "\$args->{q{$init_arg}}";
  3390.  
  3391.             $code .= "if (exists $value) {\n";
  3392.  
  3393.             if($need_coercion){
  3394.                 $value = "$constraint_var->coerce($value)";
  3395.             }
  3396.  
  3397.             $code .= "$instance_slot = $value;\n";
  3398.             $code .= $post_process;
  3399.  
  3400.             if ($attr->has_trigger) {
  3401.                 $has_triggers++;
  3402.                 $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
  3403.             }
  3404.  
  3405.             if ($strict){
  3406.                 $code .= '++$used;' . "\n";
  3407.             }
  3408.  
  3409.             $code .= "\n} else {\n"; # $value exists
  3410.         }
  3411.  
  3412.         if ($attr->has_default || $attr->has_builder) {
  3413.             unless ($attr->is_lazy) {
  3414.                 my $default = $attr->default;
  3415.                 my $builder = $attr->builder;
  3416.  
  3417.                 my $value;
  3418.                 if (defined($builder)) {
  3419.                     $value = "\$instance->$builder()";
  3420.                 }
  3421.                 elsif (ref($default) eq 'CODE') {
  3422.                     $value = "$attr_var\->{default}->(\$instance)";
  3423.                 }
  3424.                 elsif (defined($default)) {
  3425.                     $value = "$attr_var\->{default}";
  3426.                 }
  3427.                 else {
  3428.                     $value = 'undef';
  3429.                 }
  3430.  
  3431.                 if($need_coercion){
  3432.                     $value = "$constraint_var->coerce($value)";
  3433.                 }
  3434.  
  3435.                 $code .= "$instance_slot = $value;\n";
  3436.                 if($is_weak_ref){
  3437.                     $code .= "Scalar::Util::weaken($instance_slot);\n";
  3438.                 }
  3439.             }
  3440.         }
  3441.         elsif ($attr->is_required) {
  3442.             $code .= "Carp::confess('Attribute ($key) is required');";
  3443.         }
  3444.  
  3445.         $code .= "}\n" if defined $init_arg;
  3446.  
  3447.         push @res, $code;
  3448.     }
  3449.  
  3450.     if($strict){
  3451.         push @res, q{if($used < keys %{$args})}
  3452.             . q{{ $metaclass->_report_unknown_args(\@attrs, $args) }};
  3453.     }
  3454.  
  3455.     if($metaclass->is_anon_class){
  3456.         push @res, q{$instance->{__METACLASS__} = $metaclass;};
  3457.     }
  3458.  
  3459.     if($has_triggers){
  3460.         unshift @res, q{my @triggers;};
  3461.         push    @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
  3462.     }
  3463.  
  3464.     return join "\n", @res;
  3465. }
  3466.  
  3467. sub _generate_BUILDARGS {
  3468.     my(undef, $metaclass) = @_;
  3469.  
  3470.     my $class = $metaclass->name;
  3471.     if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
  3472.         return 'my $args = $class->BUILDARGS(@_)';
  3473.     }
  3474.  
  3475.     return <<'...';
  3476.         my $args;
  3477.         if ( scalar @_ == 1 ) {
  3478.             ( ref( $_[0] ) eq 'HASH' )
  3479.                 || Carp::confess "Single parameters to new() must be a HASH ref";
  3480.             $args = +{ %{ $_[0] } };
  3481.         }
  3482.         else {
  3483.             $args = +{@_};
  3484.         }
  3485. ...
  3486. }
  3487.  
  3488. sub _generate_BUILDALL {
  3489.     my (undef, $metaclass) = @_;
  3490.  
  3491.     return '' unless $metaclass->name->can('BUILD');
  3492.  
  3493.     my @code;
  3494.     for my $class ($metaclass->linearized_isa) {
  3495.         if (Mouse::Util::get_code_ref($class, 'BUILD')) {
  3496.             unshift  @code, qq{${class}::BUILD(\$instance, \$args);};
  3497.         }
  3498.     }
  3499.     return join "\n", @code;
  3500. }
  3501.  
  3502. }
  3503. BEGIN{ # lib/Mouse/Meta/Method/Delegation.pm
  3504. package Mouse::Meta::Method::Delegation;
  3505. use Mouse::Util qw(:meta); # enables strict and warnings
  3506. use Scalar::Util;
  3507.  
  3508. sub _generate_delegation{
  3509.     my (undef, $attr, $handle_name, $method_to_call) = @_;
  3510.  
  3511.     my @curried_args;
  3512.     if(ref($method_to_call) eq 'ARRAY'){
  3513.         ($method_to_call, @curried_args) = @{$method_to_call};
  3514.     }
  3515.  
  3516.     my $reader = $attr->get_read_method_ref();
  3517.  
  3518.     my $can_be_optimized = $attr->{_method_delegation_can_be_optimized};
  3519.  
  3520.     if(!defined $can_be_optimized){
  3521.         my $tc     = $attr->type_constraint;
  3522.  
  3523.         $attr->{_method_delegation_can_be_optimized} =
  3524.             (defined($tc) && $tc->is_a_type_of('Object'))
  3525.             && ($attr->is_required || $attr->has_default || $attr->has_builder)
  3526.             && ($attr->is_lazy || !$attr->has_clearer);
  3527.     }
  3528.  
  3529.     if($can_be_optimized){
  3530.         # need not check the attribute value
  3531.         return sub {
  3532.             return shift()->$reader()->$method_to_call(@curried_args, @_);
  3533.         };
  3534.     }
  3535.     else {
  3536.         # need to check the attribute value
  3537.         return sub {
  3538.             my $instance = shift;
  3539.             my $proxy    = $instance->$reader();
  3540.  
  3541.             my $error = !defined($proxy)                              ? ' is not defined'
  3542.                       : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')}
  3543.                                                                       : undef;
  3544.             if ($error) {
  3545.                 $instance->meta->throw_error(
  3546.                     "Cannot delegate $handle_name to $method_to_call because "
  3547.                         . "the value of "
  3548.                         . $attr->name
  3549.                         . $error
  3550.                  );
  3551.             }
  3552.             $proxy->$method_to_call(@curried_args, @_);
  3553.         };
  3554.     }
  3555. }
  3556.  
  3557.  
  3558. }
  3559. BEGIN{ # lib/Mouse/Meta/Method/Destructor.pm
  3560. package Mouse::Meta::Method::Destructor;
  3561. use Mouse::Util qw(:meta); # enables strict and warnings
  3562.  
  3563. sub _empty_DESTROY{ }
  3564.  
  3565. sub _generate_destructor{
  3566.     my (undef, $metaclass) = @_;
  3567.  
  3568.     if(!$metaclass->name->can('DEMOLISH')){
  3569.         return \&_empty_DESTROY;
  3570.     }
  3571.  
  3572.     my $demolishall = '';
  3573.     for my $class ($metaclass->linearized_isa) {
  3574.         if (Mouse::Util::get_code_ref($class, 'DEMOLISH')) {
  3575.             $demolishall .= sprintf "%s::DEMOLISH(\$self, \$Mouse::Util::in_global_destruction);\n",
  3576.                 $class,
  3577.         }
  3578.     }
  3579.  
  3580.     my $source = sprintf(<<'END_DESTROY', __LINE__, __FILE__, $demolishall);
  3581. #line %d %s
  3582.     sub {
  3583.         my $self = shift;
  3584.         my $e = do{
  3585.             local $?;
  3586.             local $@;
  3587.             eval{
  3588.                 # demolishall
  3589.                 %s;
  3590.             };
  3591.             $@;
  3592.         };
  3593.         no warnings 'misc';
  3594.         die $e if $e; # rethrow
  3595.     }
  3596. END_DESTROY
  3597.  
  3598.     my $code;
  3599.     my $e = do{
  3600.         local $@;
  3601.         $code = eval $source;
  3602.         $@;
  3603.     };
  3604.     die $e if $e;
  3605.     return $code;
  3606. }
  3607.  
  3608. }
  3609. BEGIN{ # lib/Mouse/Meta/Module.pm
  3610. package Mouse::Meta::Module;
  3611. use Mouse::Util qw/:meta get_code_package get_code_ref not_supported/; # enables strict and warnings
  3612.  
  3613. use Carp         ();
  3614. use Scalar::Util ();
  3615.  
  3616. my %METAS;
  3617.  
  3618. if(Mouse::Util::MOUSE_XS){
  3619.     # register meta storage for performance
  3620.     Mouse::Util::__register_metaclass_storage(\%METAS, 0);
  3621.  
  3622.     # ensure thread safety
  3623.     *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
  3624. }
  3625.  
  3626. sub _metaclass_cache { # DEPRECATED
  3627.     my($self, $name) = @_;
  3628.     Carp::cluck('_metaclass_cache() has been deprecated. Use Mouse::Util::get_metaclass_by_name() instead');
  3629.     return $METAS{$name};
  3630. }
  3631.  
  3632. sub initialize {
  3633.     my($class, $package_name, @args) = @_;
  3634.  
  3635.     ($package_name && !ref($package_name))
  3636.         || $class->throw_error("You must pass a package name and it cannot be blessed");
  3637.  
  3638.     return $METAS{$package_name}
  3639.         ||= $class->_construct_meta(package => $package_name, @args);
  3640. }
  3641.  
  3642. sub reinitialize {
  3643.     my($class, $package_name, @args) = @_;
  3644.  
  3645.     $package_name = $package_name->name if ref $package_name;
  3646.  
  3647.     ($package_name && !ref($package_name))
  3648.         || $class->throw_error("You must pass a package name and it cannot be blessed");
  3649.  
  3650.     delete $METAS{$package_name};
  3651.     return $class->initialize($package_name, @args);
  3652. }
  3653.  
  3654. sub _class_of{
  3655.     my($class_or_instance) = @_;
  3656.     return undef unless defined $class_or_instance;
  3657.     return $METAS{ ref($class_or_instance) || $class_or_instance };
  3658. }
  3659.  
  3660. # Means of accessing all the metaclasses that have
  3661. # been initialized thus far
  3662. #sub _get_all_metaclasses         {        %METAS         }
  3663. sub _get_all_metaclass_instances { values %METAS         }
  3664. sub _get_all_metaclass_names     { keys   %METAS         }
  3665. sub _get_metaclass_by_name       { $METAS{$_[0]}         }
  3666. #sub _store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
  3667. #sub _weaken_metaclass            { weaken($METAS{$_[0]}) }
  3668. #sub _does_metaclass_exist        { defined $METAS{$_[0]} }
  3669. #sub _remove_metaclass_by_name    { delete $METAS{$_[0]}  }
  3670.  
  3671. sub name;
  3672.  
  3673. sub namespace;
  3674.  
  3675. # add_attribute is an abstract method
  3676.  
  3677. sub get_attribute_map { # DEPRECATED
  3678.     Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead');
  3679.     return $_[0]->{attributes};
  3680. }
  3681.  
  3682. sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  3683. sub get_attribute     {        $_[0]->{attributes}->{$_[1]} }
  3684. sub remove_attribute  { delete $_[0]->{attributes}->{$_[1]} }
  3685.  
  3686. sub get_attribute_list{ keys   %{$_[0]->{attributes}} }
  3687.  
  3688. # XXX: for backward compatibility
  3689. my %foreign = map{ $_ => undef } qw(
  3690.     Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
  3691.     Carp Scalar::Util List::Util
  3692. );
  3693. sub _code_is_mine{
  3694. #    my($self, $code) = @_;
  3695.  
  3696.     return !exists $foreign{ get_code_package($_[1]) };
  3697. }
  3698.  
  3699. sub add_method;
  3700.  
  3701. sub has_method {
  3702.     my($self, $method_name) = @_;
  3703.  
  3704.     defined($method_name)
  3705.         or $self->throw_error('You must define a method name');
  3706.  
  3707.     return defined($self->{methods}{$method_name}) || do{
  3708.         my $code = get_code_ref($self->{package}, $method_name);
  3709.         $code && $self->_code_is_mine($code);
  3710.     };
  3711. }
  3712.  
  3713. sub get_method_body {
  3714.     my($self, $method_name) = @_;
  3715.  
  3716.     defined($method_name)
  3717.         or $self->throw_error('You must define a method name');
  3718.  
  3719.     return $self->{methods}{$method_name} ||= do{
  3720.         my $code = get_code_ref($self->{package}, $method_name);
  3721.         $code && $self->_code_is_mine($code) ? $code : undef;
  3722.     };
  3723. }
  3724.  
  3725. sub get_method{
  3726.     my($self, $method_name) = @_;
  3727.  
  3728.     if(my $code = $self->get_method_body($method_name)){
  3729.         return Mouse::Util::load_class($self->method_metaclass)->wrap(
  3730.             body                 => $code,
  3731.             name                 => $method_name,
  3732.             package              => $self->name,
  3733.             associated_metaclass => $self,
  3734.         );
  3735.     }
  3736.  
  3737.     return undef;
  3738. }
  3739.  
  3740. sub get_method_list {
  3741.     my($self) = @_;
  3742.  
  3743.     return grep { $self->has_method($_) } keys %{ $self->namespace };
  3744. }
  3745.  
  3746. sub _collect_methods { # Mouse specific
  3747.     my($meta, @args) = @_;
  3748.  
  3749.     my @methods;
  3750.     foreach my $arg(@args){
  3751.         if(my $type = ref $arg){
  3752.             if($type eq 'Regexp'){
  3753.                 push @methods, grep { $_ =~ $arg } $meta->get_all_method_names;
  3754.             }
  3755.             elsif($type eq 'ARRAY'){
  3756.                 push @methods, @{$arg};
  3757.             }
  3758.             else{
  3759.                 my $subname = ( caller(1) )[3];
  3760.                 $meta->throw_error(
  3761.                     sprintf(
  3762.                         'Methods passed to %s must be provided as a list, ArrayRef or regular expression, not %s',
  3763.                         $subname,
  3764.                         $type,
  3765.                     )
  3766.                 );
  3767.             }
  3768.          }
  3769.          else{
  3770.             push @methods, $arg;
  3771.          }
  3772.      }
  3773.      return @methods;
  3774. }
  3775.  
  3776. my $ANON_SERIAL = 0;  # anonymous class/role id
  3777. my %IMMORTALS;        # immortal anonymous classes
  3778.  
  3779. sub create {
  3780.     my($self, $package_name, %options) = @_;
  3781.  
  3782.     my $class = ref($self) || $self;
  3783.     $self->throw_error('You must pass a package name') if @_ < 2;
  3784.  
  3785.     my $superclasses;
  3786.     if(exists $options{superclasses}){
  3787.         if(Mouse::Util::is_a_metarole($self)){
  3788.             delete $options{superclasses};
  3789.         }
  3790.         else{
  3791.             $superclasses = delete $options{superclasses};
  3792.             (ref $superclasses eq 'ARRAY')
  3793.                 || $self->throw_error("You must pass an ARRAY ref of superclasses");
  3794.         }
  3795.     }
  3796.  
  3797.     my $attributes = delete $options{attributes};
  3798.     if(defined $attributes){
  3799.         (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
  3800.             || $self->throw_error("You must pass an ARRAY ref of attributes");
  3801.     }
  3802.     my $methods = delete $options{methods};
  3803.     if(defined $methods){
  3804.         (ref $methods eq 'HASH')
  3805.             || $self->throw_error("You must pass a HASH ref of methods");
  3806.     }
  3807.     my $roles = delete $options{roles};
  3808.     if(defined $roles){
  3809.         (ref $roles eq 'ARRAY')
  3810.             || $self->throw_error("You must pass an ARRAY ref of roles");
  3811.     }
  3812.     my $mortal;
  3813.     my $cache_key;
  3814.  
  3815.     if(!defined $package_name){ # anonymous
  3816.         $mortal = !$options{cache};
  3817.  
  3818.         # anonymous but immortal
  3819.         if(!$mortal){
  3820.                 # something like Super::Class|Super::Class::2=Role|Role::1
  3821.                 $cache_key = join '=' => (
  3822.                     join('|',      @{$superclasses || []}),
  3823.                     join('|', sort @{$roles        || []}),
  3824.                 );
  3825.                 return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
  3826.         }
  3827.         $options{anon_serial_id} = ++$ANON_SERIAL;
  3828.         $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
  3829.     }
  3830.  
  3831.     # instantiate a module
  3832.     {
  3833.         no strict 'refs';
  3834.         ${ $package_name . '::VERSION'   } = delete $options{version}   if exists $options{version};
  3835.         ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
  3836.     }
  3837.  
  3838.     my $meta = $self->initialize( $package_name, %options);
  3839.  
  3840.     Scalar::Util::weaken $METAS{$package_name}
  3841.         if $mortal;
  3842.  
  3843.     $meta->add_method(meta => sub {
  3844.         $self->initialize(ref($_[0]) || $_[0]);
  3845.     });
  3846.  
  3847.     $meta->superclasses(@{$superclasses})
  3848.         if defined $superclasses;
  3849.  
  3850.     # NOTE:
  3851.     # process attributes first, so that they can
  3852.     # install accessors, but locally defined methods
  3853.     # can then overwrite them. It is maybe a little odd, but
  3854.     # I think this should be the order of things.
  3855.     if (defined $attributes) {
  3856.         if(ref($attributes) eq 'ARRAY'){
  3857.             # array of Mouse::Meta::Attribute
  3858.             foreach my $attr (@{$attributes}) {
  3859.                 $meta->add_attribute($attr);
  3860.             }
  3861.         }
  3862.         else{
  3863.             # hash map of name and attribute spec pairs
  3864.             while(my($name, $attr) = each %{$attributes}){
  3865.                 $meta->add_attribute($name => $attr);
  3866.             }
  3867.         }
  3868.     }
  3869.     if (defined $methods) {
  3870.         while(my($method_name, $method_body) = each %{$methods}){
  3871.             $meta->add_method($method_name, $method_body);
  3872.         }
  3873.     }
  3874.     if (defined $roles){
  3875.         Mouse::Util::apply_all_roles($package_name, @{$roles});
  3876.     }
  3877.  
  3878.     if($cache_key){
  3879.         $IMMORTALS{$cache_key} = $meta;
  3880.     }
  3881.  
  3882.     return $meta;
  3883. }
  3884.  
  3885. sub DESTROY{
  3886.     my($self) = @_;
  3887.  
  3888.     return if $Mouse::Util::in_global_destruction;
  3889.  
  3890.     my $serial_id = $self->{anon_serial_id};
  3891.  
  3892.     return if !$serial_id;
  3893.     # mortal anonymous class
  3894.  
  3895.     # XXX: cleaning stash with threads causes panic/SEGV.
  3896.     if(exists $INC{'threads.pm'}) {
  3897.         # (caller)[2] indicates the caller's line number,
  3898.         # which is zero when the current thread is joining.
  3899.         return if( (caller)[2] == 0);
  3900.     }
  3901.  
  3902.     # @ISA is a magical variable, so we clear it manually.
  3903.     @{$self->{superclasses}} = () if exists $self->{superclasses};
  3904.  
  3905.     # Then, clear the symbol table hash
  3906.     %{$self->namespace} = ();
  3907.  
  3908.     my $name = $self->name;
  3909.     delete $METAS{$name};
  3910.  
  3911.     $name =~ s/ $serial_id \z//xms;
  3912.     no strict 'refs';
  3913.     delete ${$name}{ $serial_id . '::' };
  3914.  
  3915.     return;
  3916. }
  3917.  
  3918. sub throw_error{
  3919.     my($self, $message, %args) = @_;
  3920.  
  3921.     local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
  3922.     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
  3923.  
  3924.     if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
  3925.         Carp::croak($message);
  3926.     }
  3927.     else{
  3928.         Carp::confess($message);
  3929.     }
  3930. }
  3931.  
  3932. }
  3933. BEGIN{ # lib/Mouse/Meta/Role.pm
  3934. package Mouse::Meta::Role;
  3935. use Mouse::Util qw(:meta not_supported); # enables strict and warnings
  3936.  
  3937. use Mouse::Meta::Module;
  3938. our @ISA = qw(Mouse::Meta::Module);
  3939.  
  3940. sub method_metaclass;
  3941.  
  3942. sub _construct_meta {
  3943.     my $class = shift;
  3944.  
  3945.     my %args  = @_;
  3946.  
  3947.     $args{methods}          = {};
  3948.     $args{attributes}       = {};
  3949.     $args{required_methods} = [];
  3950.     $args{roles}            = [];
  3951.  
  3952.     my $self = bless \%args, ref($class) || $class;
  3953.     if($class ne __PACKAGE__){
  3954.         $self->meta->_initialize_object($self, \%args);
  3955.     }
  3956.  
  3957.     return $self;
  3958. }
  3959.  
  3960. sub create_anon_role{
  3961.     my $self = shift;
  3962.     return $self->create(undef, @_);
  3963. }
  3964.  
  3965. sub is_anon_role;
  3966.  
  3967. sub get_roles;
  3968.  
  3969. sub calculate_all_roles {
  3970.     my $self = shift;
  3971.     my %seen;
  3972.     return grep { !$seen{ $_->name }++ }
  3973.            ($self, map  { $_->calculate_all_roles } @{ $self->get_roles });
  3974. }
  3975.  
  3976. sub get_required_method_list{
  3977.     return @{ $_[0]->{required_methods} };
  3978. }
  3979.  
  3980. sub add_required_methods {
  3981.     my($self, @methods) = @_;
  3982.     my %required = map{ $_ => 1 } @{$self->{required_methods}};
  3983.     push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
  3984.     return;
  3985. }
  3986.  
  3987. sub requires_method {
  3988.     my($self, $name) = @_;
  3989.     return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
  3990. }
  3991.  
  3992. sub add_attribute {
  3993.     my $self = shift;
  3994.     my $name = shift;
  3995.  
  3996.     $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
  3997.     return;
  3998. }
  3999.  
  4000. sub _check_required_methods{
  4001.     my($role, $consumer, $args) = @_;
  4002.  
  4003.     if($args->{_to} eq 'role'){
  4004.         $consumer->add_required_methods($role->get_required_method_list);
  4005.     }
  4006.     else{ # to class or instance
  4007.         my $consumer_class_name = $consumer->name;
  4008.  
  4009.         my @missing;
  4010.         foreach my $method_name(@{$role->{required_methods}}){
  4011.             next if exists $args->{aliased_methods}{$method_name};
  4012.             next if exists $role->{methods}{$method_name};
  4013.             next if $consumer_class_name->can($method_name);
  4014.  
  4015.             push @missing, $method_name;
  4016.         }
  4017.         if(@missing){
  4018.             $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
  4019.                 $role->name,
  4020.                 (@missing == 1 ? '' : 's'), # method or methods
  4021.                 Mouse::Util::quoted_english_list(@missing),
  4022.                 $consumer_class_name);
  4023.         }
  4024.     }
  4025.  
  4026.     return;
  4027. }
  4028.  
  4029. sub _apply_methods{
  4030.     my($role, $consumer, $args) = @_;
  4031.  
  4032.     my $alias    = $args->{-alias};
  4033.     my $excludes = $args->{-excludes};
  4034.  
  4035.     foreach my $method_name($role->get_method_list){
  4036.         next if $method_name eq 'meta';
  4037.  
  4038.         my $code = $role->get_method_body($method_name);
  4039.  
  4040.         if(!exists $excludes->{$method_name}){
  4041.             if(!$consumer->has_method($method_name)){
  4042.                 # The third argument $role is used in Role::Composite
  4043.                 $consumer->add_method($method_name => $code, $role);
  4044.             }
  4045.         }
  4046.  
  4047.         if(exists $alias->{$method_name}){
  4048.             my $dstname = $alias->{$method_name};
  4049.  
  4050.             my $dstcode = $consumer->get_method_body($dstname);
  4051.  
  4052.             if(defined($dstcode) && $dstcode != $code){
  4053.                 $role->throw_error("Cannot create a method alias if a local method of the same name exists");
  4054.             }
  4055.             else{
  4056.                 $consumer->add_method($dstname => $code, $role);
  4057.             }
  4058.         }
  4059.     }
  4060.  
  4061.     return;
  4062. }
  4063.  
  4064. sub _apply_attributes{
  4065.     #my($role, $consumer, $args) = @_;
  4066.     my($role, $consumer) = @_;
  4067.  
  4068.     for my $attr_name ($role->get_attribute_list) {
  4069.         next if $consumer->has_attribute($attr_name);
  4070.  
  4071.         $consumer->add_attribute($attr_name => $role->get_attribute($attr_name));
  4072.     }
  4073.     return;
  4074. }
  4075.  
  4076. sub _apply_modifiers{
  4077.     #my($role, $consumer, $args) = @_;
  4078.     my($role, $consumer) = @_;
  4079.  
  4080.  
  4081.     if(my $modifiers = $role->{override_method_modifiers}){
  4082.         foreach my $method_name (keys %{$modifiers}){
  4083.             $consumer->add_override_method_modifier($method_name => $modifiers->{$method_name});
  4084.         }
  4085.     }
  4086.  
  4087.     for my $modifier_type (qw/before around after/) {
  4088.         my $table = $role->{"${modifier_type}_method_modifiers"}
  4089.             or next;
  4090.  
  4091.         my $add_modifier = "add_${modifier_type}_method_modifier";
  4092.  
  4093.         while(my($method_name, $modifiers) = each %{$table}){
  4094.             foreach my $code(@{ $modifiers }){
  4095.                 next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
  4096.                 $consumer->$add_modifier($method_name => $code);
  4097.             }
  4098.         }
  4099.     }
  4100.     return;
  4101. }
  4102.  
  4103. sub _append_roles{
  4104.     #my($role, $consumer, $args) = @_;
  4105.     my($role, $consumer) = @_;
  4106.  
  4107.     my $roles = $consumer->{roles};
  4108.  
  4109.     foreach my $r($role, @{$role->get_roles}){
  4110.         if(!$consumer->does_role($r)){
  4111.             push @{$roles}, $r;
  4112.         }
  4113.     }
  4114.     return;
  4115. }
  4116.  
  4117. # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
  4118. sub apply {
  4119.     my $self     = shift;
  4120.     my $consumer = shift;
  4121.  
  4122.     my %args = (@_ == 1) ? %{ $_[0] } : @_;
  4123.  
  4124.     my $instance;
  4125.  
  4126.     if(Mouse::Util::is_a_metaclass($consumer)){  # Application::ToClass
  4127.         $args{_to} = 'class';
  4128.     }
  4129.     elsif(Mouse::Util::is_a_metarole($consumer)){ # Application::ToRole
  4130.         $args{_to} = 'role';
  4131.     }
  4132.     else{                                       # Appplication::ToInstance
  4133.         $args{_to} = 'instance';
  4134.         $instance  = $consumer;
  4135.  
  4136.         $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')->create_anon_class(
  4137.             superclasses => [ref $instance],
  4138.             cache        => 1,
  4139.         );
  4140.     }
  4141.  
  4142.     if($args{alias} && !exists $args{-alias}){
  4143.         $args{-alias} = $args{alias};
  4144.     }
  4145.     if($args{excludes} && !exists $args{-excludes}){
  4146.         $args{-excludes} = $args{excludes};
  4147.     }
  4148.  
  4149.     $args{aliased_methods} = {};
  4150.     if(my $alias = $args{-alias}){
  4151.         @{$args{aliased_methods}}{ values %{$alias} } = ();
  4152.     }
  4153.  
  4154.     if(my $excludes = $args{-excludes}){
  4155.         $args{-excludes} = {}; # replace with a hash ref
  4156.         if(ref $excludes){
  4157.             %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
  4158.         }
  4159.         else{
  4160.             $args{-excludes}{$excludes} = undef;
  4161.         }
  4162.     }
  4163.  
  4164.     $self->_check_required_methods($consumer, \%args);
  4165.     $self->_apply_attributes($consumer, \%args);
  4166.     $self->_apply_methods($consumer, \%args);
  4167.     $self->_apply_modifiers($consumer, \%args);
  4168.     $self->_append_roles($consumer, \%args);
  4169.  
  4170.  
  4171.     if(defined $instance){ # Application::ToInstance
  4172.         # rebless instance
  4173.         bless $instance, $consumer->name;
  4174.         $consumer->_initialize_object($instance, $instance, 1);
  4175.     }
  4176.  
  4177.     return;
  4178. }
  4179.  
  4180.  
  4181. sub combine {
  4182.     my($self, @role_specs) = @_;
  4183.  
  4184.     require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace
  4185.  
  4186.     my $composite = Mouse::Meta::Role::Composite->create_anon_role();
  4187.  
  4188.     foreach my $role_spec (@role_specs) {
  4189.         my($role_name, $args) = @{$role_spec};
  4190.         $role_name->meta->apply($composite, %{$args});
  4191.     }
  4192.     return $composite;
  4193. }
  4194.  
  4195. sub add_before_method_modifier;
  4196. sub add_around_method_modifier;
  4197. sub add_after_method_modifier;
  4198.  
  4199. sub get_before_method_modifiers;
  4200. sub get_around_method_modifiers;
  4201. sub get_after_method_modifiers;
  4202.  
  4203. sub add_override_method_modifier{
  4204.     my($self, $method_name, $method) = @_;
  4205.  
  4206.     if($self->has_method($method_name)){
  4207.         # This error happens in the override keyword or during role composition,
  4208.         # so I added a message, "A local method of ...", only for compatibility (gfx)
  4209.         $self->throw_error("Cannot add an override of method '$method_name' "
  4210.                    . "because there is a local version of '$method_name'"
  4211.                    . "(A local method of the same name as been found)");
  4212.     }
  4213.  
  4214.     $self->{override_method_modifiers}->{$method_name} = $method;
  4215. }
  4216.  
  4217. sub get_override_method_modifier {
  4218.     my ($self, $method_name) = @_;
  4219.     return $self->{override_method_modifiers}->{$method_name};
  4220. }
  4221.  
  4222. sub does_role {
  4223.     my ($self, $role_name) = @_;
  4224.  
  4225.     (defined $role_name)
  4226.         || $self->throw_error("You must supply a role name to look for");
  4227.  
  4228.     $role_name = $role_name->name if ref $role_name;
  4229.  
  4230.     # if we are it,.. then return true
  4231.     return 1 if $role_name eq $self->name;
  4232.     # otherwise.. check our children
  4233.     for my $role (@{ $self->get_roles }) {
  4234.         return 1 if $role->does_role($role_name);
  4235.     }
  4236.     return 0;
  4237. }
  4238.  
  4239. }
  4240. BEGIN{ # lib/Mouse/Meta/Role/Composite.pm
  4241. package Mouse::Meta::Role::Composite;
  4242. use Mouse::Util; # enables strict and warnings
  4243. use Mouse::Meta::Role;
  4244. our @ISA = qw(Mouse::Meta::Role);
  4245.  
  4246. sub get_method_list{
  4247.     my($self) = @_;
  4248.     return keys %{ $self->{methods} };
  4249. }
  4250.  
  4251. sub add_method {
  4252.     my($self, $method_name, $code, $role) = @_;
  4253.  
  4254.     if( ($self->{methods}{$method_name} || 0) == $code){
  4255.         # This role already has the same method.
  4256.         return;
  4257.     }
  4258.  
  4259.     if($method_name eq 'meta'){
  4260.         $self->SUPER::add_method($method_name => $code);
  4261.     }
  4262.     else{
  4263.         # no need to add a subroutine to the stash
  4264.         my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
  4265.         push @{$roles}, $role;
  4266.         if(@{$roles} > 1){
  4267.             $self->{conflicting_methods}{$method_name}++;
  4268.         }
  4269.         $self->{methods}{$method_name} = $code;
  4270.     }
  4271.     return;
  4272. }
  4273.  
  4274. sub get_method_body {
  4275.     my($self, $method_name) = @_;
  4276.     return $self->{methods}{$method_name};
  4277. }
  4278.  
  4279. sub has_method {
  4280.     # my($self, $method_name) = @_;
  4281.     return 0; # to fool _apply_methods() in combine()
  4282. }
  4283.  
  4284. sub has_attribute{
  4285.     # my($self, $method_name) = @_;
  4286.     return 0; # to fool _appply_attributes() in combine()
  4287. }
  4288.  
  4289. sub has_override_method_modifier{
  4290.     # my($self, $method_name) = @_;
  4291.     return 0; # to fool _apply_modifiers() in combine()
  4292. }
  4293.  
  4294. sub add_attribute{
  4295.     my $self      = shift;
  4296.     my $attr_name = shift;
  4297.     my $spec      = (@_ == 1 ? $_[0] : {@_});
  4298.  
  4299.     my $existing = $self->{attributes}{$attr_name};
  4300.     if($existing && $existing != $spec){
  4301.         $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
  4302.                          . "during composition. This is fatal error and cannot be disambiguated.");
  4303.     }
  4304.     $self->SUPER::add_attribute($attr_name, $spec);
  4305.     return;
  4306. }
  4307.  
  4308. sub add_override_method_modifier{
  4309.     my($self, $method_name, $code) = @_;
  4310.  
  4311.     my $existing = $self->{override_method_modifiers}{$method_name};
  4312.     if($existing && $existing != $code){
  4313.         $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
  4314.                           . "composition (Two 'override' methods of the same name encountered). "
  4315.                           . "This is fatal error.")
  4316.     }
  4317.     $self->SUPER::add_override_method_modifier($method_name, $code);
  4318.     return;
  4319. }
  4320.  
  4321. # components of apply()
  4322.  
  4323. sub _apply_methods{
  4324.     my($self, $consumer, $args) = @_;
  4325.  
  4326.     if(exists $self->{conflicting_methods}){
  4327.         my $consumer_class_name = $consumer->name;
  4328.  
  4329.         my @conflicting = grep{ !$consumer_class_name->can($_) } keys %{ $self->{conflicting_methods} };
  4330.  
  4331.         if(@conflicting == 1){
  4332.             my $method_name = $conflicting[0];
  4333.             my $roles       = Mouse::Util::quoted_english_list(map{ $_->name } @{ $self->{composed_roles_by_method}{$method_name} });
  4334.             $self->throw_error(
  4335.                sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
  4336.                    $roles, $method_name, $consumer_class_name
  4337.             );
  4338.         }
  4339.         elsif(@conflicting > 1){
  4340.             my %seen;
  4341.             my $roles = Mouse::Util::quoted_english_list(
  4342.                 grep{ !$seen{$_}++ } # uniq
  4343.                 map { $_->name }
  4344.                 map { @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
  4345.             );
  4346.  
  4347.             $self->throw_error(
  4348.                sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
  4349.                    $roles,
  4350.                    Mouse::Util::quoted_english_list(@conflicting),
  4351.                    $consumer_class_name
  4352.             );
  4353.         }
  4354.     }
  4355.  
  4356.     $self->SUPER::_apply_methods($consumer, $args);
  4357.     return;
  4358. }
  4359. }
  4360. BEGIN{ # lib/Mouse/Meta/Role/Method.pm
  4361. package Mouse::Meta::Role::Method;
  4362. use Mouse::Util; # enables strict and warnings
  4363.  
  4364. use Mouse::Meta::Method;
  4365. our @ISA = qw(Mouse::Meta::Method);
  4366.  
  4367. sub _new{
  4368.     my($class, %args) = @_;
  4369.     my $self = bless \%args, $class;
  4370.  
  4371.     if($class ne __PACKAGE__){
  4372.         $self->meta->_initialize_object($self, \%args);
  4373.     }
  4374.     return $self;
  4375. }
  4376.  
  4377. }
  4378. BEGIN{ # lib/Mouse/Object.pm
  4379. package Mouse::Object;
  4380. use Mouse::Util qw(does dump meta); # enables strict and warnings
  4381.  
  4382. sub new;
  4383. sub BUILDARGS;
  4384. sub BUILDALL;
  4385.  
  4386. sub DESTROY;
  4387. sub DEMOLISHALL;
  4388.  
  4389. }
  4390. BEGIN{ # lib/Mouse/Role.pm
  4391. package Mouse::Role;
  4392. use Mouse::Exporter; # enables strict and warnings
  4393.  
  4394. our $VERSION = '0.64';
  4395.  
  4396. use Carp         qw(confess);
  4397. use Scalar::Util qw(blessed);
  4398.  
  4399. use Mouse::Util  qw(not_supported);
  4400. use Mouse::Meta::Role;
  4401. use Mouse ();
  4402.  
  4403. Mouse::Exporter->setup_import_methods(
  4404.     as_is => [qw(
  4405.         extends with
  4406.         has
  4407.         before after around
  4408.         override super
  4409.         augment  inner
  4410.  
  4411.         requires excludes
  4412.     ),
  4413.         \&Scalar::Util::blessed,
  4414.         \&Carp::confess,
  4415.     ],
  4416. );
  4417.  
  4418.  
  4419. sub extends  {
  4420.     Carp::croak "Roles do not support 'extends'";
  4421. }
  4422.  
  4423. sub with     {
  4424.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4425.     Mouse::Util::apply_all_roles($meta->name, @_);
  4426.     return;
  4427. }
  4428.  
  4429. sub has {
  4430.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4431.     my $name = shift;
  4432.  
  4433.     $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
  4434.         if @_ % 2; # odd number of arguments
  4435.  
  4436.     if(ref $name){ # has [qw(foo bar)] => (...)
  4437.         for (@{$name}){
  4438.             $meta->add_attribute($_ => @_);
  4439.         }
  4440.     }
  4441.     else{ # has foo => (...)
  4442.         $meta->add_attribute($name => @_);
  4443.     }
  4444.     return;
  4445. }
  4446.  
  4447. sub before {
  4448.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4449.     my $code = pop;
  4450.     for my $name($meta->_collect_methods(@_)) {
  4451.         $meta->add_before_method_modifier($name => $code);
  4452.     }
  4453.     return;
  4454. }
  4455.  
  4456. sub after {
  4457.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4458.     my $code = pop;
  4459.     for my $name($meta->_collect_methods(@_)) {
  4460.         $meta->add_after_method_modifier($name => $code);
  4461.     }
  4462.     return;
  4463. }
  4464.  
  4465. sub around {
  4466.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4467.     my $code = pop;
  4468.     for my $name($meta->_collect_methods(@_)) {
  4469.         $meta->add_around_method_modifier($name => $code);
  4470.     }
  4471.     return;
  4472. }
  4473.  
  4474.  
  4475. sub super {
  4476.     return if !defined $Mouse::SUPER_BODY;
  4477.     $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
  4478. }
  4479.  
  4480. sub override {
  4481.     # my($name, $code) = @_;
  4482.     Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_);
  4483.     return;
  4484. }
  4485.  
  4486. # We keep the same errors messages as Moose::Role emits, here.
  4487. sub inner {
  4488.     Carp::croak "Roles cannot support 'inner'";
  4489. }
  4490.  
  4491. sub augment {
  4492.     Carp::croak "Roles cannot support 'augment'";
  4493. }
  4494.  
  4495. sub requires {
  4496.     my $meta = Mouse::Meta::Role->initialize(scalar caller);
  4497.     $meta->throw_error("Must specify at least one method") unless @_;
  4498.     $meta->add_required_methods(@_);
  4499.     return;
  4500. }
  4501.  
  4502. sub excludes {
  4503.     not_supported;
  4504. }
  4505.  
  4506. sub init_meta{
  4507.     shift;
  4508.     my %args = @_;
  4509.  
  4510.     my $class = $args{for_class}
  4511.         or Carp::confess("Cannot call init_meta without specifying a for_class");
  4512.  
  4513.     my $metaclass  = $args{metaclass}  || 'Mouse::Meta::Role';
  4514.  
  4515.     my $meta = $metaclass->initialize($class);
  4516.  
  4517.     $meta->add_method(meta => sub{
  4518.         $metaclass->initialize(ref($_[0]) || $_[0]);
  4519.     });
  4520.  
  4521.     # make a role type for each Mouse role
  4522.     Mouse::Util::TypeConstraints::role_type($class)
  4523.         unless Mouse::Util::TypeConstraints::find_type_constraint($class);
  4524.  
  4525.     return $meta;
  4526. }
  4527.  
  4528. }
  4529. BEGIN{ # lib/Mouse/Util/MetaRole.pm
  4530. package Mouse::Util::MetaRole;
  4531. use Mouse::Util; # enables strict and warnings
  4532. use Scalar::Util ();
  4533.  
  4534. sub apply_metaclass_roles {
  4535.     my %args = @_;
  4536.     _fixup_old_style_args(\%args);
  4537.  
  4538.     return apply_metaroles(%args);
  4539. }
  4540.  
  4541. sub apply_metaroles {
  4542.     my %args = @_;
  4543.  
  4544.     my $for = Scalar::Util::blessed($args{for})
  4545.         ?                                     $args{for}
  4546.         : Mouse::Util::get_metaclass_by_name( $args{for} );
  4547.  
  4548.     if(!$for){
  4549.         Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass");
  4550.     }
  4551.  
  4552.     if ( Mouse::Util::is_a_metarole($for) ) {
  4553.         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
  4554.     }
  4555.     else {
  4556.         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
  4557.     }
  4558. }
  4559.  
  4560. sub _make_new_metaclass {
  4561.     my($for, $roles, $primary) = @_;
  4562.  
  4563.     return $for unless keys %{$roles};
  4564.  
  4565.     my $new_metaclass = exists($roles->{$primary})
  4566.         ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
  4567.         :                  ref $for;
  4568.  
  4569.     my %classes;
  4570.  
  4571.     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
  4572.         my $metaclass;
  4573.         my $attr = $for->can($metaclass = ($key . '_metaclass'))
  4574.                 || $for->can($metaclass = ($key . '_class'))
  4575.                 || $for->throw_error("Unknown metaclass '$key'");
  4576.  
  4577.         $classes{ $metaclass }
  4578.             = _make_new_class( $for->$attr(), $roles->{$key} );
  4579.     }
  4580.  
  4581.     return $new_metaclass->reinitialize( $for, %classes );
  4582. }
  4583.  
  4584.  
  4585. sub _fixup_old_style_args {
  4586.     my $args = shift;
  4587.  
  4588.     return if $args->{class_metaroles} || $args->{roles_metaroles};
  4589.  
  4590.     $args->{for} = delete $args->{for_class}
  4591.         if exists $args->{for_class};
  4592.  
  4593.     my @old_keys = qw(
  4594.         attribute_metaclass_roles
  4595.         method_metaclass_roles
  4596.         wrapped_method_metaclass_roles
  4597.         instance_metaclass_roles
  4598.         constructor_class_roles
  4599.         destructor_class_roles
  4600.         error_class_roles
  4601.  
  4602.         application_to_class_class_roles
  4603.         application_to_role_class_roles
  4604.         application_to_instance_class_roles
  4605.         application_role_summation_class_roles
  4606.     );
  4607.  
  4608.     my $for = Scalar::Util::blessed($args->{for})
  4609.         ?                                     $args->{for}
  4610.         : Mouse::Util::get_metaclass_by_name( $args->{for} );
  4611.  
  4612.     my $top_key;
  4613.     if( Mouse::Util::is_a_metaclass($for) ){
  4614.         $top_key = 'class_metaroles';
  4615.  
  4616.         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
  4617.             if exists $args->{metaclass_roles};
  4618.     }
  4619.     else {
  4620.         $top_key = 'role_metaroles';
  4621.  
  4622.         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
  4623.             if exists $args->{metaclass_roles};
  4624.     }
  4625.  
  4626.     for my $old_key (@old_keys) {
  4627.         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
  4628.  
  4629.         $args->{$top_key}{$new_key} = delete $args->{$old_key}
  4630.             if exists $args->{$old_key};
  4631.     }
  4632.  
  4633.     return;
  4634. }
  4635.  
  4636.  
  4637. sub apply_base_class_roles {
  4638.     my %options = @_;
  4639.  
  4640.     my $for = $options{for_class};
  4641.  
  4642.     my $meta = Mouse::Util::class_of($for);
  4643.  
  4644.     my $new_base = _make_new_class(
  4645.         $for,
  4646.         $options{roles},
  4647.         [ $meta->superclasses() ],
  4648.     );
  4649.  
  4650.     $meta->superclasses($new_base)
  4651.         if $new_base ne $meta->name();
  4652.     return;
  4653. }
  4654.  
  4655. sub _make_new_class {
  4656.     my($existing_class, $roles, $superclasses) = @_;
  4657.  
  4658.     if(!$superclasses){
  4659.         return $existing_class if !$roles;
  4660.  
  4661.         my $meta = Mouse::Meta::Class->initialize($existing_class);
  4662.  
  4663.         return $existing_class
  4664.             if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
  4665.     }
  4666.  
  4667.     return Mouse::Meta::Class->create_anon_class(
  4668.         superclasses => $superclasses ? $superclasses : [$existing_class],
  4669.         roles        => $roles,
  4670.         cache        => 1,
  4671.     )->name();
  4672. }
  4673.  
  4674. }
  4675. END_OF_TINY
  4676.     die $@ if $@;
  4677. } # unless Mouse.pm is loaded
  4678. package Mouse::Tiny;
  4679.  
  4680. our $VERSION = '0.64';
  4681.  
  4682. Mouse::Exporter->setup_import_methods(also => 'Mouse');
  4683.  
  4684. 1;
  4685.